Private Declare Function WinGBitBlt Lib "wing32.dll" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long) As Long
#Else
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
#End If
Const SRCCOPY = &HCC0020
Const PIXELS_PER_BITBLT = 1
Const TYPE_UP = 1
Const TYPE_DOWN = -1
' add a new Menu to the collection
' Parameters: sCaption Caption of the Menu
' lIndex Location of the Menu in Menus collection
Public Function Add(ByVal sCaption As String, lIndex As Long, ByVal picMenu As Object) As VMenu
Dim newMenu As New VMenu
On Error Resume Next
With newMenu
.Caption = sCaption
.Index = lIndex
Set .Control = picMenu
.ButtonHeight = mlButtonHeight
End With
' add the item to the collection specified by lIndex
' note, if there is nothing in the collection, just add it
' if there is nothing in the collection or we are adding it at then end, just add it
' elseif we are inserting in the first position, add it BEFORE
' else add it AFTER the previous item
If colMenus.Count = 0 Then
colMenus.Add newMenu
ElseIf lIndex = colMenus.Count + 1 Then
colMenus.Add newMenu
ElseIf lIndex = 1 Then
colMenus.Add newMenu, , 1
Else
colMenus.Add newMenu, , , lIndex - 1
End If
Set Add = newMenu
End Function
' delete the Menu from the collection
' Parameters: lIndex Index of the collection member
Public Sub Delete(lIndex As Long)
On Error Resume Next
colMenus.Remove lIndex
End Sub
' return the object of the Menu in the collection
' Parameters: lIndex Index of the collection member
Public Property Get Item(lIndex As Variant) As VMenu
On Error Resume Next
If lIndex > 0 Then
Set Item = colMenus(lIndex)
End If
End Property
' return the number of Menus in the collection
Public Function Count() As Long
On Error Resume Next
Count = colMenus.Count
End Function
' move a Menu to a new location
' Parameters: lCurIndex the current location
' lNewIndex the new location
Public Sub MoveMenu(lCurIndex As Long, lNewIndex As Long)
' under construction
End Sub
' move a MenuItem to a new location
' Parameters: lCurIndex the current location
' lNewIndex the new location
Public Sub MoveMenuItem(lCurIndex As Long, lNewIndex As Long)
' undex construction
End Sub
Public Property Get Caption(lIndex As Long) As String
On Error Resume Next
Caption = colMenus(lIndex).Caption
End Property
Public Property Let Caption(lIndex As Long, sNewValue As String)
On Error Resume Next
colMenus(lIndex).Caption = sNewValue
End Property
Public Property Get ButtonHeight() As Long
On Error Resume Next
ButtonHeight = mlButtonHeight
End Property
Public Property Let ButtonHeight(ByVal lNewValue As Long)
On Error Resume Next
mlButtonHeight = lNewValue
End Property
Public Property Set Menu(oNewValue As PictureBox)
On Error Resume Next
Set picMenu = oNewValue
End Property
Public Property Set Cache(oNewValue As PictureBox)
On Error Resume Next
Set picCache = oNewValue
End Property
Public Property Let MenuCur(lNewValue As Long)
On Error Resume Next
mlMenuCur = lNewValue
End Property
' Procedure: Paint
' This is the main procedure that paints our control
' It handles repaints as well as well as changes of the
' current menu
' Since we can move several menus at once, the code for
' this is done here in the collection of menus rather then
' the the menu class itself. However, the painting of the
' MenuItems is done in the MenuItem class itself.
Public Sub Paint()
On Error Resume Next
If mlMenuPrev = 0 Then ' first time paint
mlMenuPrev = mlMenuCur
End If
If mlMenuPrev = mlMenuCur Then
Repaint
ElseIf mlMenuPrev < mlMenuCur Then ' user selected a menu after the previously selected menu
ReselectDown
Else ' user selected a menu before the previously selected menu
ReselectUp
End If
DrawIcons
SetMenuButtonsHotSpot
mlMenuPrev = mlMenuCur ' save this menu as the next previous menu
End Sub
' repaint the menu as is - no changes were made
' support subroutine for Paint
Private Sub Repaint()
Dim l As Long
Dim lMax As Long
Dim lResult As Long
Dim hDestDC As Long
Dim hSrcDC As Long
Dim sCaption As String
Dim lWidth As Long
Dim lHeight As Long
On Error Resume Next
' setup variables
lMax = colMenus.Count
With picMenu
' if we just changed the number of menus then
' we need to clear the control first
If mbNumberOfMenusChanged Then
.Cls
mbNumberOfMenusChanged = False
End If
hDestDC = .hdc
.ScaleMode = vbPixels
.ForeColor = vbButtonText
lWidth = CLng(.ScaleWidth)
lHeight = CLng(.ScaleHeight)
End With
hSrcDC = picCache.hdc
If lMax = 0 Or hDestDC = 0 Or hSrcDC = 0 Then
Exit Sub
End If
' first, paint the menus up to the currently select one