Public VBInstance As VBIDE.VBE
Public Connect As Connect
Option Explicit
Private Sub CancelButton_Click()
Connect.Hide
End Sub
Private Sub cmdAbout_Click()
frmAbout.Show vbModal
End Sub
Private Sub cmdAdd_Click()
Dim Msg$, i%
Msg = InputBox("Введите имя для основного меню:", "Создание меню")
If Trim(Msg) <> vbNullString Then
For i = 0 To lstMenu.ListCount - 1
If UCase(lstMenu.List(i)) = UCase(Trim(Msg)) Then
MsgBox "Меню с именем '" & Trim(Msg) & "' уже существует!", _
vbInformation + vbOKOnly, "Ошибка!"
Exit Sub
End If
Next
Msg = Trim(Replace(Msg, " ", ""))
lstMenu.AddItem Msg
End If
End Sub
Private Sub cmdDelete_Click()
If lstMenu.ListIndex = -1 Then Exit Sub
If MsgBox("Удалить меню '" & lstMenu.List(lstMenu.ListIndex) &
_
"' ?", vbYesNo + vbQuestion + vbDefaultButton2, "Удаление меню")
_
= vbYes Then
lstMenu.RemoveItem lstMenu.ListIndex
End If
End Sub
Private Sub Form_Load()
lblInfo.Caption = "Данный Add-In компонует коды для создания нестандартного бокового меню." & _
vbCrLf & "Выберите форму, куда Вы собираетесь это меню вставить и сформируйте перечень основных меню."
End Sub
Private Sub OKButton_Click()
Dim thisProject As VBProject
Dim thisForm As VBForm
Dim PanelMenu As VBControl
Dim ctrlMenu As VBControl
Dim mnuMenu As VBControl
Dim mnuSubMenu As VBControl
Dim thisCode As CodeModule
Dim i%, j%, NumOptExp%
If cboForm.ListCount = 0 Then
MsgBox "Должна существовать хотя бы одна форма.",
_
vbInformation + vbOKOnly, "Ошибка!"
Exit Sub
End If
If lstMenu.ListCount = 0 Then
MsgBox "Необходимо создать, хотя бы одно меню.",
_
vbInformation + vbOKOnly, "Ошибка!"
Exit Sub
End If
Screen.MousePointer = vbHourglass
If ErrName = False Then
Exit Sub
End If
Set thisProject = VBInstance.ActiveVBProject
Set thisForm = thisProject.VBComponents.Item(cboForm.Text).Designer
Set PanelMenu = thisForm.ContainedVBControls.Add("PictureBox")
With PanelMenu
.Properties("Name") = "picBack"
.Properties("Align") = 3
.Properties("AutoRedraw") = True
.Properties("BorderStyle") = 0
.Properties("ScaleMode") = 3
.Properties("Width") = 375
End With
For i = 0 To lstMenu.ListCount - 1
Set ctrlMenu = PanelMenu.ContainedVBControls.Add("PictureBox")
With ctrlMenu
.Properties("Name") = lstMenu.List(i)
.Properties("AutoRedraw") = True
.Properties("BorderStyle") = 0
.Properties("ScaleMode") = 3
.Properties("Left") = 4
.Properties("Height") = 33
.Properties("Width") = 17
End With
Set mnuMenu = thisForm.ContainedVBControls.Add("Menu")
With mnuMenu
.Properties("Name") = lstMenu.List(i) & "1"
.Properties("Caption") = lstMenu.List(i)
.Properties("Visible") = False
End With
For j = 0 To 1
Set mnuSubMenu = mnuMenu.ContainedVBControls.Add("Menu")
With mnuSubMenu
.Properties("Index") = j
.Properties("Name") = "Sub" & lstMenu.List(i)
.Properties("Caption") = "Sub" & lstMenu.List(i)
.Properties("Visible") = True
End With
Next
Next
Set thisCode = thisProject.VBComponents.Item(cboForm.Text).CodeModule
'Если Option Explicit не на первой строке
For i = 1 To 20
If thisCode.Lines(i, 1) = "Option Explicit" Then
NumOptExp = i + 1
Exit For
Else
NumOptExp = 1
End If
Next
thisCode.InsertLines NumOptExp, CodeText
Set thisProject = Nothing
Set thisForm = Nothing
Set PanelMenu = Nothing
Set ctrlMenu = Nothing
Set mnuMenu = Nothing
Set mnuSubMenu = Nothing
Set thisCode = Nothing
Screen.MousePointer = vbDefault
frmConfirm.Show vbModal
Connect.Hide
End Sub
Private Function ErrName() As Boolean
Dim TempProject As VBProject
Dim TempForm As VBForm
Dim iControl As Integer, sCtrl As String, i%, TempName$
Set TempProject = VBInstance.ActiveVBProject
Set TempForm = TempProject.VBComponents.Item(cboForm.Text).Designer
For iControl = 1 To TempForm.VBControls.Count
TempName = TempForm.VBControls.Item(iControl).Properties("Name")
If TempName = "picBack" Then
sCtrl = "picBack"
GoTo LineErr
End If
For i = 0 To lstMenu.ListCount - 1
If TempName = lstMenu.List(i) Then
sCtrl = lstMenu.List(i)
GoTo LineErr
ElseIf TempName = lstMenu.List(i) & "1" Then
sCtrl = lstMenu.List(i) & "1"
GoTo LineErr
ElseIf TempName = "Sub" & lstMenu.List(i) Then
sCtrl = "Sub" & lstMenu.List(i)
GoTo LineErr
End If
Next
Next
ErrName = True
GoTo LineExit
LineErr:
MsgBox "На форме '" & cboForm.Text & "' уже имеется элемент с именем '" & _
sCtrl & "'. Ваши возможные дальнейшие действия:" & vbCrLf & _
" 1. Выбрать другую форму;" & vbCrLf & _
" 2. Переименовать на форме элемент '" & sCtrl & "'" & vbCrLf & _
" 3. Удалить на форме элемент '" & sCtrl & "'", _
vbInformation + vbOKOnly, "Ошибка совпадения имен!"
ErrName = False
LineExit:
Set TempProject = Nothing
Set TempForm = Nothing
Screen.MousePointer = vbDefault
End Function
Private Function CodeText() As String
Dim Str$, i%
Str = "Private Const LOGPIXELSX = 88" & vbCrLf
Str = Str & "Private Const LOGPIXELSY = 90" & vbCrLf
Str = Str & "Private Const LF_FACESIZE = 32" & vbCrLf
Str = Str & "Private Const FW_NORMAL = 400" & vbCrLf
Str = Str & "Private Const FW_BOLD = 700" & vbCrLf
Str = Str & "Private Const FF_DONTCARE = 0" & vbCrLf
Str = Str & "Private Const DEFAULT_QUALITY = 0" & vbCrLf
Str = Str & "Private Const DEFAULT_PITCH = 0" & vbCrLf
Str = Str & "Private Const DEFAULT_CHARSET = 1" & vbCrLf
Str = Str & "Private Const CLR_INVALID = -1" & vbCrLf
Str = Str & "Private Const OUT_DEFAULT_PRECIS = 0" & vbCrLf & vbCrLf
Str = Str & "Private Type LOGFONT" & vbCrLf
Str = Str & " lfHeight As Long" & vbCrLf
Str = Str & " lfWidth As Long" & vbCrLf
Str = Str & " lfEscapement As Long" & vbCrLf
Str = Str & " lfOrientation As Long" & vbCrLf
Str = Str & " lfWeight As Long" & vbCrLf
Str = Str & " lfItalic As Byte" & vbCrLf
Str = Str & " lfUnderline As Byte" & vbCrLf
Str = Str & " lfStrikeOut As Byte" & vbCrLf
Str = Str & " lfCharSet As Byte" & vbCrLf
Str = Str & " lfOutPrecision As Byte" & vbCrLf
Str = Str & " lfClipPrecision As Byte" & vbCrLf
Str = Str & " lfQuality As Byte" & vbCrLf
Str = Str & " lfPitchAndFamily As Byte" & vbCrLf
Str = Str & " lfFaceName(LF_FACESIZE) As Byte" & vbCrLf
Str = Str & "End Type" & vbCrLf & vbCrLf
Str = Str & "Private Const SW_SHOWNORMAL = 1" & vbCrLf
Str = Str & "Private Const SRCCOPY = &HCC0020" & vbCrLf & vbCrLf
Str = Str & "Private Declare Function CreateFontIndirect Lib " _
& Chr(34) & "gdi32" & Chr(34) & " Alias " & Chr(34)
_
& "CreateFontIndirectA" & Chr(34) & " (lpLogFont As LOGFONT) As Long" & vbCrLf
Str = Str & "Private Declare Function TextOut Lib " & Chr(34) & _
"gdi32" & Chr(34) & " Alias " & Chr(34) & "TextOutA" & Chr(34) &
_
" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long,
" & _
"ByVal lpString As String, ByVal nCount As Long) As Long" & vbCrLf
Str = Str & "Private Declare Function SelectObject Lib " & Chr(34) &
_
"gdi32" & Chr(34) & " (ByVal hDC As Long, ByVal hObject As Long) As Long" & vbCrLf
Str = Str & "Private Declare Function DeleteObject Lib " & Chr(34) &
_
"gdi32" & Chr(34) & " (ByVal hObject As Long) As Long" & vbCrLf
Str = Str & "Private Declare Function GetDeviceCaps Lib " & Chr(34) &
_
"gdi32" & Chr(34) & " (ByVal hDC As Long, ByVal nIndex As Long) As Long" & vbCrLf
Str = Str & "Private Declare Function MulDiv Lib " & Chr(34) & "kernel32"
& Chr(34) & _
" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long" & vbCrLf
Str = Str & "Private Declare Function SetCapture Lib " & Chr(34) & "user32"
_
& Chr(34) & " (ByVal hwnd As Long) As Long" & vbCrLf
Str = Str & "Private Declare Function ReleaseCapture Lib " & Chr(34) & "user32" &
_
Chr(34) & " () As Long" & vbCrLf & vbCrLf
Str = Str & "Private Sub DrawSMenu(pic As PictureBox, capt As String)" & vbCrLf
Str = Str & "Dim tLF As LOGFONT" & vbCrLf
Str = Str & "Dim hFnt As Long" & vbCrLf
Str = Str & "Dim hFntOld As Long" & vbCrLf
Str = Str & "Dim lR As Long" & vbCrLf & vbCrLf
Str = Str & "On Error GoTo DrawError" & vbCrLf
Str = Str & " 'изменяем высоту в зависимости от текста" & vbCrLf
Str = Str & " 'по 4 пиксела с обеих сторон" & vbCrLf
Str = Str & " pic.Height = pic.TextWidth(capt) + 8" & vbCrLf
Str = Str & " 'рисование шрифта текста на контроле" & vbCrLf
Str = Str & " pOLEFontToLogFont pic.Font, pic.hDC, tLF" & vbCrLf
Str = Str & " 'угол наклона текста 90 градусов" & vbCrLf
Str = Str & " tLF.lfEscapement = 900" & vbCrLf
Str = Str & " hFnt = CreateFontIndirect(tLF)" & vbCrLf
Str = Str & " If (hFnt <> 0) Then" & vbCrLf
Str = Str & " hFntOld = SelectObject(pic.hDC, hFnt)" & vbCrLf
Str = Str & " 'вывод текста на контроле" & vbCrLf
Str = Str & " lR = TextOut(pic.hDC, 0, pic.Height - 4, capt, Len(capt))" & vbCrLf
Str = Str & " SelectObject pic.hDC, hFntOld" & vbCrLf
Str = Str & " DeleteObject hFnt" & vbCrLf
Str = Str & " End If" & vbCrLf
Str = Str & "Exit Sub" & vbCrLf & vbCrLf
Str = Str & "DrawError:" & vbCrLf
Str = Str & " MsgBox Err.Number & Err.Description, vbInformation, " &
_
Chr(34) & "ERROR!" & Chr(34) & vbCrLf
Str = Str & "End Sub" & vbCrLf & vbCrLf
Str = Str & "Private Sub pOLEFontToLogFont(fntThis As StdFont, hDC As Long, tLF As LOGFONT)" & vbCrLf
Str = Str & "Dim sFont As String" & vbCrLf
Str = Str & "Dim iChar As Integer" & vbCrLf & vbCrLf
Str = Str & " ' Конвертация OLE StdFont в структуру LOGFONT" & vbCrLf
Str = Str & " With tLF" & vbCrLf
Str = Str & " .lfOutPrecision = OUT_DEFAULT_PRECIS" & vbCrLf
Str = Str & " .lfClipPrecision = OUT_DEFAULT_PRECIS" & vbCrLf
Str = Str & " .lfQuality = DEFAULT_QUALITY" & vbCrLf
Str = Str & " .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE" & vbCrLf
Str = Str & " .lfCharSet = DEFAULT_CHARSET" & vbCrLf & vbCrLf
Str = Str & " sFont = fntThis.Name" & vbCrLf
Str = Str & " ' Перевод в биты" & vbCrLf
Str = Str & " For iChar = 1 To Len(sFont)" & vbCrLf
Str = Str & " .lfFaceName(iChar - 1) = CByte(Asc(Mid$(sFont, iChar, 1)))" & vbCrLf
Str = Str & " Next iChar" & vbCrLf
Str = Str & " ' установка параметров шрифта" & vbCrLf
Str = Str & " .lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hDC, LOGPIXELSY)), 72)" & vbCrLf
Str = Str & " .lfItalic = fntThis.Italic" & vbCrLf
Str = Str & " If (fntThis.Bold) Then" & vbCrLf
Str = Str & " .lfWeight = FW_BOLD" & vbCrLf
Str = Str & " Else" & vbCrLf
Str = Str & " .lfWeight = FW_NORMAL" & vbCrLf
Str = Str & " End If" & vbCrLf
Str = Str & " .lfUnderline = fntThis.Underline" & vbCrLf
Str = Str & " .lfStrikeOut = fntThis.Strikethrough" & vbCrLf
Str = Str & " End With" & vbCrLf
Str = Str & "End Sub" & vbCrLf & vbCrLf
Str = Str & "Private Sub Form_Load()" & vbCrLf
Str = Str & " 'рисуем границу" & vbCrLf
Str = Str & " With picBack" & vbCrLf
Str = Str & " picBack.Line (.ScaleWidth - 2, 0)-(.ScaleWidth - 2, .ScaleHeight), &H8000000C" & vbCrLf
Str = Str & " picBack.Line (.ScaleWidth - 1, 0)-(.ScaleWidth - 1, .ScaleHeight), &HFFFFFF" & vbCrLf
Str = Str & " End With" & vbCrLf & vbCrLf
Str = Str & " 'Данные функции поворота шрифта работают только со шрифтами TrueType." & vbCrLf
Str = Str & " 'Шрифт Tahoma наиболее близко похож на MS Sans Serif." & vbCrLf
Str = Str & " 'Если на Вашем компьютере нет этого шрифта, замените его на любой другой TrueType-шрифт" & vbCrLf
For i = 0 To lstMenu.ListCount - 1
Str = Str & " " & lstMenu.List(i) & ".FontName = " & Chr(34) & "Tahoma" & Chr(34) & vbCrLf
Str = Str & " DrawSMenu " & lstMenu.List(i) & ", " & Chr(34) & lstMenu.List(i) & Chr(34) & vbCrLf
Next
Str = Str & "End Sub" & vbCrLf & vbCrLf
Str = Str & "Private Sub Form_Resize()" & vbCrLf
Str = Str & " 'Если форма имеет свойство ScaleMode = 3' Pixel - то в кодах необходимо убрать / Screen.TwipsPerPixelY" & vbCrLf
Str = Str & " " & lstMenu.List(0) & ".Move 4, ScaleHeight / Screen.TwipsPerPixelY - "
_
& lstMenu.List(0) & ".Height - 6" & vbCrLf
For i = 1 To lstMenu.ListCount - 1
Str = Str & " " & lstMenu.List(i) & ".Move 4, " & lstMenu.List(i - 1) &
_
".Top - " & lstMenu.List(i) & ".Height - 2" & vbCrLf
Next
Str = Str & "End Sub" & vbCrLf & vbCrLf
For i = 0 To lstMenu.ListCount - 1
Str = Str & "Private Sub " & lstMenu.List(i) & "_Click()" & vbCrLf
Str = Str & " 'Если форма имеет свойство ScaleMode = 3' Pixel - то в кодах необходимо убрать * Screen.TwipsPerPixelX и * Screen.TwipsPerPixelY" & vbCrLf
Str = Str & " PopupMenu " & lstMenu.List(i) & "1, , (" & lstMenu.List(i) &
_
".Left + " & lstMenu.List(i) & ".Width) * Screen.TwipsPerPixelX, " &
_
lstMenu.List(i) & ".Top * Screen.TwipsPerPixelY" & vbCrLf
Str = Str & "End Sub" & vbCrLf & vbCrLf
Str = Str & "Private Sub " & lstMenu.List(i) & _
"_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)" & vbCrLf
Str = Str & " If X > 0 And X < " & lstMenu.List(i) & _
".ScaleWidth And Y > 0 And Y < " & lstMenu.List(i) & ".ScaleHeight Then" & vbCrLf
Str = Str & " SetCapture " & lstMenu.List(i) & ".hwnd" & vbCrLf
Str = Str & " " & lstMenu.List(i) & ".BorderStyle = 1" & vbCrLf
Str = Str & " Else" & vbCrLf
Str = Str & " ReleaseCapture" & vbCrLf
Str = Str & " " & lstMenu.List(i) & ".BorderStyle = 0" & vbCrLf
Str = Str & " End If" & vbCrLf
Str = Str & "End Sub" & vbCrLf & vbCrLf
Str = Str & "Private Sub " & lstMenu.List(i) & _
"_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)" & vbCrLf
Str = Str & " ReleaseCapture" & vbCrLf
Str = Str & " " & lstMenu.List(i) & ".BorderStyle = 0" & vbCrLf
Str = Str & "End Sub" & vbCrLf & vbCrLf
Next
CodeText = Str
End Function
| К статье | Окончание листинга |