Статьи

Листинг (окончание) к статье
"Как написать Add-In или ...
большие мучения с маленькой программой."

Форма "frmConfirm"

Option Explicit

Private Sub cmdOK_Click()
    Unload Me
End Sub

Private Sub Form_Load()
lblConfirm.Caption = "Закончено формирование бокового меню." & vbCrLf & _
    "Изменение надписей (Caption) основного меню производится в Form_Load " & _
    "в методе DrawSMenu, например так:" & vbCrLf & _
    "DrawSMenu mnuFile, " & Chr(34) & "Файл." & Chr(34) & vbCrLf & _
    "Редактирование подменю производится стандартно - через редактор меню."
End Sub

Форма "frmAbout"

Option Explicit

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const LF_FACESIZE = 32
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1
Private Const CLR_INVALID = -1
Private Const OUT_DEFAULT_PRECIS = 0

Private Type LOGFONT

lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte

End Type

Private Const SW_SHOWNORMAL = 1
Private Const SRCCOPY = &HCC0020

Private Declare Function CreateFontIndirect Lib "gdi32" _
    Alias "CreateFontIndirectA" _
    (lpLogFont As LOGFONT) _
    As Long
Private Declare Function TextOut Lib "gdi32" _
    Alias "TextOutA" _
    (ByVal hDC As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal lpString As String, _
    ByVal nCount As Long) _
    As Long
Private Declare Function SelectObject Lib "gdi32" _
    (ByVal hDC As Long, _
    ByVal hObject As Long) _
    As Long
Private Declare Function DeleteObject Lib "gdi32" _
    (ByVal hObject As Long) _
    As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
    (ByVal hDC As Long, _
    ByVal nIndex As Long) _
    As Long
Private Declare Function MulDiv Lib "kernel32" _
    (ByVal nNumber As Long, _
    ByVal nNumerator As Long, _
    ByVal nDenominator As Long) _
    As Long
Private Declare Function SetCapture Lib "user32" _
    (ByVal hwnd As Long) _
    As Long
Private Declare Function ReleaseCapture Lib "user32" _
    () As Long

Private Declare Function ShellExecute& Lib "shell32.dll" _
    Alias "ShellExecuteA" _
    (ByVal hwnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long)
Private Declare Function GetDesktopWindow Lib "user32" _
    () As Long

Private Sub DrawVMenu(pic As PictureBox, capt As String)
Dim tLF As LOGFONT
Dim hFnt As Long
Dim hFntOld As Long
Dim lR As Long

On Error GoTo DrawError
'изменяем высоту в зависимости от текста
'по 4 пиксела с обеих сторон
pic.Height = pic.TextWidth(capt) + 8
'рисование шрифта текста на контроле
pOLEFontToLogFont pic.Font, pic.hDC, tLF
'угол наклона текста 90 градусов
tLF.lfEscapement = 900
hFnt = CreateFontIndirect(tLF)
If (hFnt <> 0) Then
    hFntOld = SelectObject(pic.hDC, hFnt)
    'вывод текста на контроле
    lR = TextOut(pic.hDC, 0, pic.Height - 4, capt, Len(capt))
    SelectObject pic.hDC, hFntOld
    DeleteObject hFnt
End If
Exit Sub

DrawError:
MsgBox Err.Number & Err.Description, vbInformation, "ERROR!"
End Sub

Private Sub pOLEFontToLogFont(fntThis As StdFont, hDC As Long, tLF As LOGFONT)
Dim sFont As String
Dim iChar As Integer

' Конвертация OLE StdFont в структуру LOGFONT
With tLF
    .lfOutPrecision = OUT_DEFAULT_PRECIS
    .lfClipPrecision = OUT_DEFAULT_PRECIS
    .lfQuality = DEFAULT_QUALITY
    .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
    .lfCharSet = DEFAULT_CHARSET

    sFont = fntThis.Name
    ' Перевод в биты
    For iChar = 1 To Len(sFont)
        .lfFaceName(iChar - 1) = CByte(Asc(Mid$(sFont, iChar, 1)))
    Next iChar

    ' установка параметров шрифта
    .lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hDC, LOGPIXELSY)), 72)
    .lfItalic = fntThis.Italic
    If (fntThis.Bold) Then
        .lfWeight = FW_BOLD
    Else
        .lfWeight = FW_NORMAL
    End If
    .lfUnderline = fntThis.Underline
    .lfStrikeOut = fntThis.Strikethrough
End With
End Sub

Private Sub Form_Resize()
    mnuAbout.Move 4, ScaleHeight / Screen.TwipsPerPixelY - mnuAbout.Height - 6
End Sub

Private Sub mnuAbout_Click()
    PopupMenu mnuAbout1, , (mnuAbout.Left + mnuAbout.Width) * Screen.TwipsPerPixelX, _
    mnuAbout.Top * Screen.TwipsPerPixelY
End Sub

Private Sub mnuAbout_MouseMove(Button As Integer, _
    Shift As Integer, X As Single, Y As Single)

If X > 0 And X < mnuAbout.ScaleWidth And Y > 0 _
    And Y < mnuAbout.ScaleHeight Then

    SetCapture mnuAbout.hwnd
    mnuAbout.BorderStyle = 1
Else
    ReleaseCapture
    mnuAbout.BorderStyle = 0
End If
End Sub

Private Sub mnuAbout_MouseUp(Button As Integer, Shift As Integer, _
    X As Single, Y As Single)

    ReleaseCapture
    mnuAbout.BorderStyle = 0
End Sub

Private Sub Form_Load()
'Данные функции поворота шрифта работают только со шрифтами TrueType
'mnuAbout.FontName = "Tahoma"
With picBack
    picBack.Line (.ScaleWidth - 2, 0)-(.ScaleWidth - 2, .ScaleHeight), &H8000000C
    picBack.Line (.ScaleWidth - 1, 0)-(.ScaleWidth - 1, .ScaleHeight), &HFFFFFF
End With

DrawVMenu mnuAbout, "Exit"
lblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision
lblDescription.Caption = App.LegalCopyright
End Sub

Private Sub imgMailo_Click()
    lblMailo_Click
End Sub

Private Sub lblMailo_Click()
    Call ShellExecute(0&, "Open", "mailto:" + lblMailo.Caption + _
    "?Subject=" + "About SideMenu", "", "", SW_SHOWNORMAL)
End Sub

Private Sub mnuEMail_Click()
    lblMailo_Click
End Sub

Private Sub mnuExit_Click()
    Unload Me
End Sub