PopMenu DLL Documentation (3K)
VB5 PopupMenu DLL Binary (51K)
VB5 PopupMenu DLL Demonstration (78K)
VB5 PopupMenu DLL Full Source (184K)
VB6 PopupMenu DLL Binary (52K)
VB6 PopupMenu DLL Demonstration (76K)
VB6 PopupMenu DLL Full Source (185K)
Bugs: 12 / 13
Issues: 0 / 0
Questions: 0 / 0
23 Apr 2003
If an menu was used as a drop-down from a vbAccelerator Toolbar control, and it contained infrequently used items which were hidden, once the items were exposed they did not respond when clicked. Now all items click correctly.
When showing as a chevron in a menu, if you customised which buttons were visible they could incorrectly appear in the chevron menu.
Disabled items now draw in the correct colour when XP style is in effect.
Subclassing Without The Crashes
vbAccelerator - Contents of code file: cPopupMenu.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "cPopupMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
'
===============================================================================
=======
' Name: vbAccelerator PopupMenu Component
' Author: Steve McMahon (steve@vbaccelerator.com)
' Date: 22 November 2002
'
' Requires: SSUBTMR.DLL
' pcDibSection.cls
' pcDottedBrush.cls
' pcMemDC.cls
' pcMouse.cls
' pcNCMetrics.cls
' pcStoreMenu.cls
' mGDIAPI.bas
' mFindNewMenuWindow.bas
'
' Copyright 1998-2002 Steve McMahon for vbAccelerator
'
-------------------------------------------------------------------------------
-------
' Visit vbAccelerator - advanced free source code for VB programmers
' http://vbaccelerator.com
'
-------------------------------------------------------------7-----------------
-------
' Creates unlimited new popup menus using the API
Implements ISubclass
Private m_cNCM As New pcNCMetrics
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
' The messages we will intercept & send
Private Const WM_DESTROY = &H2
Private Const WM_MENUSELECT = &H11F
Private Const WM_MEASUREITEM = &H2C
Private Const WM_DRAWITEM = &H2B
Private Const WM_COMMAND = &H111
Private Const WM_MENUCHAR = &H120
Private Const WM_INITMENUPOPUP = &H117
Private Const WM_WININICHANGE = &H1A
Private Const WM_ENTERMENULOOP = &H211
Private Const WM_EXITMENULOOP = &H212
Private Const WM_NOTIFY = &H4E
' Win98+, 2k+
Private Const WM_MENURBUTTONUP = &H122
Private Const WM_MENUDRAG = &H123
Private Const WM_MENUGETOBJECT = &H124
Private Const WM_UNINITMENUPOPUP = &H125
Private Const WM_MENUCOMMAND = &H126
' Array of menu items
Private m_tMI() As tMenuItem
Private m_iMenuCount As Long
' Stored menus:
Private m_cStoredMenu() As pcStoreMenu
Private m_iStoreCount As Long
Private m_sCurrentlyRestoredKey As String
' Handle to image list for drawing icons:
Private m_hIml As Long
Private m_lIconSize As Long
' Where to get a tick icon for checked stuff (or -1 to use Win default):
Private m_lTickIconIndex As Long
' Where to get a option button icon for checked stuff (or -1 to use Win default)
Private m_lOptionIconIndex As Long
' hWNd of owner:
Private m_hWndOwner As Long
Private m_hWndAttached As Long
' Height of a menu item:
Private m_lMenuItemHeight As Long
' colours
Private m_oActiveMenuColor As Long
Private m_oInActiveMenuColor As Long
Private m_oMenuBackgroundColor As Long
Private m_oActiveMenuBackColor As Long
' Sub menus:
Private m_lSubMenuCount As Long
Private m_hSubMenus() As Long
' Next id to choose for a menu item:
Private m_lLastMaxId As Long
Private m_bGradientHighlight As Boolean
Private m_bButtonHighlightStyle As Boolean
Private m_bHighlightCheckedItems As Boolean
Private m_OfficeXPStyle As Boolean
Private m_sTag As String
Private m_bDrawHeadersAsSeparators As Boolean
Private m_bAcceleratorsActive As Boolean
Private m_cMemDC As pcMemDC
Private m_cBrush As pcDottedBrush
Private m_fnt As StdFont
Private m_fntSymbol As StdFont
Private m_cBitmap As pcMemDC
Private m_cBitmapLight As pcMemDC
Private m_cBitmapDark As pcMemDC
Private m_bImageProcessBitmap As Boolean
Private m_pic As IPicture
' Window/handles
Private Type tMenuWindowHandle
hMenu As Long
hwnd As Long
End Type
Private m_tWnd() As tMenuWindowHandle
Private m_iWndCount As Long
' Chevron related
Private Type tMenuWindowHandleSize
tMWH As tMenuWindowHandle
tR As RECT
iSequence As Long
End Type
Private m_bShowInfrequent As Boolean
Private WithEvents m_tmrChevron As CTimer
Attribute m_tmrChevron.VB_VarHelpID = -1
Private m_lChevronStartTime As Long
Private m_lChevronIndex As Long
Private m_lHoverIndex As Long
Private m_tChevronWnd() As tMenuWindowHandleSize
Private m_iChevronWndCount As Long
Private m_lTopMenuIndex As Long
Private m_lWndIndex As Long
Private WithEvents m_tmrChevronNavigate As CTimer
Attribute m_tmrChevronNavigate.VB_VarHelpID = -1
Private m_ptrVb6ImageList As Long
Private m_bNoAnimation As Boolean
Public Enum ECNMHeaderStyle
ecnmHeaderCaptionBar = 0
ecnmHeaderSeparator = 1
End Enum
' Events:
Public Event Click(ItemNumber As Long)
Attribute Click.VB_Description = "Fired when a menu item is clicked AND the
CreateSubClass method has been called since the menu was last shown. Normally
the return value of the ShowPopupMenu event tells you which item is clicked."
Public Event ItemHighlight(ItemNumber As Long, bEnabled As Boolean, bSeparator
As Boolean)
Attribute ItemHighlight.VB_Description = "Raised when an item is highlighted in
a pop-up menu."
Public Event MenuExit()
Attribute MenuExit.VB_Description = "Raised when a popup menu is exited."
Public Event InitPopupMenu(ParentItemNumber As Long)
Attribute InitPopupMenu.VB_Description = "Raised when a submenu is about to be
shown. You can modify the pop-up menu's contents in this event without any
problem."
Public Event UnInitPopupMenu(ParentItemNumber As Long)
Attribute UnInitPopupMenu.VB_Description = "Raised when a popup menu is hidden
(Windows 98+ and 2000+ only)"
Public Event DrawItem(ByVal hdc As Long, ByVal lMenuIndex As Long, ByRef lLeft
As Long, ByRef lTop As Long, ByRef lRight As Long, ByRef lBottom As Long,
ByVal bSelected As Boolean, ByVal bChecked As Boolean, ByVal bDisabled As
Boolean, bDoDefault As Boolean)
Public Event MeasureItem(ByVal lMenuIndex As Long, ByRef lWidth As Long, ByRef
lHeight As Long)
Public Sub ToolbarMenuChevronPress()
Attribute ToolbarMenuChevronPress.VB_Description = "Special method used by
vbAccelerator Toolbar control when used in CoolMenu mode to support menu
chevron clicks."
Attribute ToolbarMenuChevronPress.VB_MemberFlags = "40"
If m_iChevronWndCount > 1 Then
' Debug.Print "Preparing to Navigate"
Set m_tmrChevronNavigate = New CTimer
m_tmrChevronNavigate.Interval = 10
m_tmrChevronNavigate.Item = 2
End If
End Sub
Public Property Get AcceleratorsActive() As Boolean
Attribute AcceleratorsActive.VB_Description = "Gets whether the object which
owns this menu is responding to accelerators or not."
AcceleratorsActive = (m_hWndOwner = getActiveWindow())
End Property
Public Property Get BackgroundPicture() As StdPicture
Attribute BackgroundPicture.VB_Description = "Gets/sets a background picture to
be displayed behind menu items."
Set BackgroundPicture = m_pic
End Property
Public Property Let BackgroundPicture(ByRef iPic As StdPicture)
pSetPicture iPic
End Property
Public Property Set BackgroundPicture(ByRef iPic As StdPicture)
pSetPicture iPic
End Property
Public Property Get ImageProcessHighlights() As Boolean
Attribute ImageProcessHighlights.VB_Description = "Gets/sets whether the
control will use image processing to the background picture to create smoother
highlights and shadows."
ImageProcessHighlights = m_bImageProcessBitmap
End Property
Public Property Let ImageProcessHighlights(ByVal bState As Boolean)
If Not bState = m_bImageProcessBitmap Then
m_bImageProcessBitmap = bState
If Not (m_cBitmap Is Nothing) Then
If bState Then
imageProcessBackgroundBitmap
Else
Set m_cBitmapLight = Nothing
Set m_cBitmapDark = Nothing
End If
End If
End If
End Property
Private Sub pSetPicture(ByRef iPic As IPicture)
If Not iPic Is Nothing Then
Set m_pic = iPic
Set m_cBitmapLight = Nothing
Set m_cBitmapDark = Nothing
Set m_cBitmap = New pcMemDC
m_cBitmap.CreateFromPicture iPic
imageProcessBackgroundBitmap
Else
Set m_cBitmap = Nothing
Set m_cBitmapLight = Nothing
Set m_cBitmapDark = Nothing
End If
End Sub
Private Sub imageProcessBackgroundBitmap()
If m_bImageProcessBitmap Then
Dim cDib As New pcDibSection
If cDib.Create(m_cBitmap.Width, m_cBitmap.Height) Then
' create a lighter version:
cDib.LoadPictureBlt m_cBitmap.hdc
cDib.Lighten 30
Set m_cBitmapLight = New pcMemDC
m_cBitmapLight.Width = m_cBitmap.Width
m_cBitmapLight.Height = m_cBitmap.Height
cDib.PaintPicture m_cBitmapLight.hdc
' create a darker version:
cDib.LoadPictureBlt m_cBitmap.hdc
cDib.Fade 120
Set m_cBitmapDark = New pcMemDC
m_cBitmapDark.Width = m_cBitmap.Width
m_cBitmapDark.Height = m_cBitmap.Height
cDib.PaintPicture m_cBitmapDark.hdc
End If
End If
End Sub
Public Sub ClearBackgroundPicture()
Attribute ClearBackgroundPicture.VB_Description = "Removes any background
picture associated with the menu."
pSetPicture Nothing
End Sub
Private Property Get hFontSymbol() As Long
Dim iFn As IFont
Set iFn = m_fntSymbol
hFontSymbol = iFn.hFont
End Property
Public Property Let Font( _
fntThis As IFont _
)
Attribute Font.VB_Description = "Gets/sets the font used to draw the menu
items."
pSetFont fntThis
End Property
Public Property Set Font( _
fntThis As IFont _
)
pSetFont fntThis
End Property
Public Property Get Font() As IFont
Dim lHDC As Long
If m_fnt Is Nothing Then
lHDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
Set Font = m_cNCM.Font(lHDC, MenuFOnt)
DeleteDC lHDC
Else
Set Font = m_fnt
End If
End Property
Private Sub pSetFont(fntThis As IFont)
Set m_fnt = fntThis
m_fntSymbol.Size = Font.Size * 1.3
Dim tR As RECT, hFntOld As Long
hFntOld = SelectObject(m_cMemDC.hdc, hFont)
DrawText m_cMemDC.hdc, "Xg", -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_CALCRECT
SelectObject m_cMemDC.hdc, hFntOld
m_lMenuItemHeight = tR.bottom - tR.top + 2
If m_lMenuItemHeight < m_lIconSize - 1 Then
m_lMenuItemHeight = m_lIconSize - 1
End If
Dim i As Long
For i = 1 To m_iMenuCount
ResetMenuForRecalc i
Next i
End Sub
Private Property Get hFont() As Long
Dim iFn As IFont
Set iFn = Font
hFont = iFn.hFont
End Property
Private Property Get hFontBold() As Long
Dim iFn As IFont
Dim iFn2 As IFont
Set iFn = Font
iFn.Clone iFn2
iFn2.Bold = True
hFontBold = iFn2.hFont
End Property
Public Property Let ActiveMenuForeColor(ByVal oColor As OLE_COLOR)
Attribute ActiveMenuForeColor.VB_Description = "Sets the foreground colour for
an active (highlighted) menu item."
m_oActiveMenuColor = oColor
End Property
Public Property Get ActiveMenuForeColor() As OLE_COLOR
If m_oActiveMenuColor = CLR_INVALID Then
ActiveMenuForeColor = vbHighlightText
Else
ActiveMenuForeColor = m_oActiveMenuColor
End If
End Property
Public Property Let ActiveMenuBackgroundColor(ByVal oColor As OLE_COLOR)
Attribute ActiveMenuBackgroundColor.VB_Description = "Sets the background
colour for an active (highlighted) menu item."
m_oActiveMenuBackColor = oColor
End Property
Public Property Get ActiveMenuBackgroundColor() As OLE_COLOR
If m_oActiveMenuBackColor = CLR_INVALID Then
ActiveMenuBackgroundColor = vbHighlight
Else
ActiveMenuBackgroundColor = m_oActiveMenuBackColor
End If
End Property
Public Property Let InActiveMenuForeColor(ByVal oColor As OLE_COLOR)
Attribute InActiveMenuForeColor.VB_Description = "Sets the background colour
for an inactive (non-highlighted) menu item."
m_oInActiveMenuColor = oColor
End Property
Public Property Get InActiveMenuForeColor() As OLE_COLOR
If m_oInActiveMenuColor = CLR_INVALID Then
InActiveMenuForeColor = vbMenuText
Else
InActiveMenuForeColor = m_oInActiveMenuColor
End If
End Property
Public Property Let MenuBackgroundColor(ByVal oColor As OLE_COLOR)
Attribute MenuBackgroundColor.VB_Description = "Gets/sets the background colour
used to draw inactive (non-highlighted) menu items."
m_oMenuBackgroundColor = oColor
End Property
Public Property Get MenuBackgroundColor() As OLE_COLOR
If m_oMenuBackgroundColor = CLR_INVALID Then
If (m_OfficeXPStyle) Then
MenuBackgroundColor = vbWindowBackground
Else
MenuBackgroundColor = vbMenuBar
End If
Else
MenuBackgroundColor = m_oMenuBackgroundColor
End If
End Property
Friend Function AcceleratorPress(ByVal nKeyCode As KeyCodeConstants, ByVal
wMask As ShiftConstants) As Boolean
Dim i As Long
' 1.2TI
' we need to check if the object which owns is
' is the active system window:
If getTheActiveWindow Then
For i = 1 To m_iMenuCount
If Not m_tMI(i).iShortCutShiftKey = 0 Then
Debug.Print "Accel Press..."; nKeyCode, wMask,
m_tMI(i).iShortCutShiftKey, m_tMI(i).iShortCutShiftMask
If m_tMI(i).iShortCutShiftMask = wMask Then
If m_tMI(i).iShortCutShiftKey = nKeyCode Then
' 1.2SPM Need to check if item is enabled/visible before it
is clicked!
If m_tMI(i).bEnabled And m_tMI(i).bVisible Then
' Yo!
raiseClickEventSub i
AcceleratorPress = True
Exit For
End If
End If
End If
End If
Next i
Else
'Debug.Print "Ignoring accelerator: owner form is not active"
End If
End Function
Private Function getTheActiveWindow() As Boolean
Dim lhWnd As Long
lhWnd = getActiveWindow()
If lhWnd = m_hWndOwner Then
' is active
getTheActiveWindow = True
Else
lhWnd = GetProp(lhWnd, TOOLWINDOWPARENTWINDOWHWND)
If lhWnd = m_hWndOwner Then
' is active
getTheActiveWindow = True
End If
End If
End Function
Public Property Get IDForItem(ByVal lIndex As Long) As Long
Attribute IDForItem.VB_Description = "Returns the Menu ID used to identify a
menu item. If the menu has a child menu, this will be the menu handle of the
child menu."
If lIndex > 0 And lIndex <= m_iMenuCount Then
IDForItem = m_tMI(lIndex).lActualID
End If
End Property
Public Property Get ItemForID(ByVal wID As Long) As Long
Attribute ItemForID.VB_Description = "Returns the Index of the menu item with
the specified ID."
Dim lIndex As Long
For lIndex = 1 To m_iMenuCount
If m_tMI(lIndex).lActualID = wID Then
ItemForID = lIndex
Exit For
End If
Next lIndex
End Property
Public Sub EmulateMenuClick(ByVal wID As Long)
Attribute EmulateMenuClick.VB_Description = "Given the ID of a menu item, calls
the code cPopupMenu would normally run when the item is clicked."
Dim lIndex As Long
For lIndex = 1 To m_iMenuCount
If m_tMI(lIndex).lActualID = wID Then
RaiseClickEvent wID
Exit For
End If
Next lIndex
End Sub
Public Property Get OfficeXpStyle() As Boolean
Attribute OfficeXpStyle.VB_Description = "Gets/sets whether the menus draw with
the new Office XP style."
OfficeXpStyle = m_OfficeXPStyle
End Property
Public Property Let OfficeXpStyle(ByVal bState As Boolean)
m_OfficeXPStyle = bState
End Property
Public Property Get GradientHighlight() As Boolean
Attribute GradientHighlight.VB_Description = "Gets/sets whether highlights on
the menu are drawn with a gradient or not."
GradientHighlight = m_bGradientHighlight
End Property
Public Property Let GradientHighlight(ByVal bState As Boolean)
m_bGradientHighlight = bState
End Property
Public Property Get ButtonHighlight() As Boolean
Attribute ButtonHighlight.VB_Description = "Gets/sets whether highlights are
drawn like toolbar buttons rather than the standard menu highlighting style."
ButtonHighlight = m_bButtonHighlightStyle
End Property
Public Property Let ButtonHighlight(ByVal bState As Boolean)
m_bButtonHighlightStyle = bState
End Property
Public Property Get HeaderStyle() As ECNMHeaderStyle
Attribute HeaderStyle.VB_Description = "Gets/sets how header style menu items
will be drawn. Header style items can either be drawn in an ICQ-style (when a
standard menu separator is drawn but the text is rendered in a small font) or
in a small window caption style."
If (m_bDrawHeadersAsSeparators) Then
HeaderStyle = ecnmHeaderSeparator
Else
HeaderStyle = ecnmHeaderCaptionBar
End If
End Property
Public Property Let HeaderStyle(ByVal eStyle As ECNMHeaderStyle)
If (eStyle = ecnmHeaderCaptionBar) Then
m_bDrawHeadersAsSeparators = False
Else
m_bDrawHeadersAsSeparators = True
End If
End Property
Public Property Get Count() As Long
Attribute Count.VB_Description = "Gets the number of items in the menu."
Count = m_iMenuCount
End Property
Public Property Get HighlightCheckedItems() As Boolean
Attribute HighlightCheckedItems.VB_Description = "Gets/sets whether checked
items should be highlighted when the menu item is selected."
HighlightCheckedItems = m_bHighlightCheckedItems
End Property
Public Property Let HighlightCheckedItems(ByVal bState As Boolean)
m_bHighlightCheckedItems = bState
End Property
Public Property Get NoMenuAnimation() As Boolean
Attribute NoMenuAnimation.VB_Description = "Gets/sets whether to disable the
default menu animation (if any) when the menu is shown."
NoMenuAnimation = m_bNoAnimation
End Property
Public Property Let NoMenuAnimation(ByVal bState As Boolean)
m_bNoAnimation = bState
End Property
Public Property Get Tag() As String
Attribute Tag.VB_Description = "Gets/sets a string associated with the
popup-menu object."
Tag = m_sTag
End Property
Public Property Let Tag(ByVal sTag As String)
m_sTag = sTag
End Property
Public Property Get CurrentlyRestoredKey() As String
Attribute CurrentlyRestoredKey.VB_Description = "Returns the currently active
menu. See Store and Restore for more details."
CurrentlyRestoredKey = m_sCurrentlyRestoredKey
End Property
Public Sub Store(ByVal sKey As String)
Attribute Store.VB_Description = "Stores the current popup menu for later
retrieval with the Restore command."
Dim lIndex As Long
Dim i As Long
Dim bShowInfrequent As Boolean
m_sCurrentlyRestoredKey = ""
bShowInfrequent = m_bShowInfrequent
If Not bShowInfrequent Then
showInfrequentlyUsed True
End If
' Save the menu under the key sKey:
lIndex = plStored(sKey)
If (lIndex = 0) Then
' We need a new item
m_iStoreCount = m_iStoreCount + 1
ReDim Preserve m_cStoredMenu(1 To m_iStoreCount) As pcStoreMenu
Set m_cStoredMenu(m_iStoreCount) = New pcStoreMenu
lIndex = m_iStoreCount
End If
With m_cStoredMenu(lIndex)
.Key = sKey
.Store m_tMI(), m_iMenuCount
End With
m_sCurrentlyRestoredKey = sKey
If Not bShowInfrequent Then
showInfrequentlyUsed False
End If
End Sub
Public Sub Restore(ByVal sKey As String)
Attribute Restore.VB_Description = "Restores a previously created menu saved
with the Store command."
Dim lIndex As Long
Dim bShowInfrequent As Boolean
' Restore the menu from the key sKey:
If (sKey <> m_sCurrentlyRestoredKey) Then
lIndex = plStored(sKey)
If (lIndex > 0) Then
' Clear any menu:
Clear
m_sCurrentlyRestoredKey = ""
bShowInfrequent = m_bShowInfrequent
If Not bShowInfrequent Then
showInfrequentlyUsed True
End If
' Restore from storage:
m_cStoredMenu(lIndex).Restore Me
If Not bShowInfrequent Then
showInfrequentlyUsed False
End If
m_sCurrentlyRestoredKey = sKey
Else
' Error
pErr "Failed to restore..."
End If
Else
'Debug.Print "Nothing to do.."
End If
End Sub
Public Function StoreToFile( _
Optional ByVal iFile As Long = -1, _
Optional ByVal sFile As String = "" _
)
Attribute StoreToFile.VB_Description = "Saves all menus to a file. Specifiy
either a filename or an open file handle to save to."
' SPM Deprecated. Use SaveToXml instead
Dim i As Long
Dim iUseFile As Integer
' Really we should be de/serialising to a PStream via the IStream
' interface (i.e. PropertyBag)
If iFile < 1 And sFile = "" Then
Err.Raise 9, App.EXEName & ".cPopupMenu", "Invalid call to
RestoreFromFile; specify file name or handle."
Exit Function
End If
If m_iStoreCount > 0 Then
On Error Resume Next
Kill sFile
Err.Clear
On Error GoTo ErrorHandler
If iFile = -1 Then
iUseFile = FreeFile
Open sFile For Binary Access Write Lock Read As #iUseFile
Else
iUseFile = iFile
End If
Put #iUseFile, , "vbalNewMenu"
Put #iUseFile, , m_iStoreCount
For i = 1 To m_iStoreCount
m_cStoredMenu(i).Serialise iUseFile
Next i
If iFile = -1 Then
Close #iUseFile
End If
iUseFile = 0
Else
Err.Raise 9, App.EXEName & ".cPopupMenu", "No stored menus to save"
End If
Exit Function
ErrorHandler:
Dim lErr As Long, sErr As String
lErr = Err.Number: sErr = Err.Description
If iUseFile > 0 And iFile = -1 Then
Close #iUseFile
iUseFile = 0
End If
Err.Raise lErr, App.EXEName & ".cPopupMenu", sErr
Exit Function
End Function
Public Function RestoreFromFile( _
Optional ByVal iFile As Long = -1, _
Optional ByVal sFile As String = "" _
)
Attribute RestoreFromFile.VB_Description = "Restores all menus previously saved
to a file using StoreToFile. Specifiy either a filename or an open file
handle to the file containing the stored data."
' SPM Deprecated. Use LoadFromXml instead
Dim i As Long
Dim iUseFile As Long
Dim sBuf As String
Dim lCount As Long
Dim bFail As Boolean
Dim sError As String
' Really we should be de/serialising to a PStream via the IStream
' interface (i.e. PropertyBag)
If iFile < 1 And sFile = "" Then
Err.Raise 9, App.EXEName & ".cPopupMenu", "Invalid call to
RestoreFromFile; specify file name or handle."
Exit Function
End If
On Error GoTo ErrorHandler
If iFile = -1 Then
iUseFile = FreeFile
Open sFile For Binary Access Read Lock Write As #iUseFile
Else
iUseFile = iFile
End If
sBuf = Space$(11)
Get #iUseFile, , sBuf
If sBuf = "vbalNewMenu" Then
Get #iUseFile, , lCount
If lCount > 0 Then
Clear
m_iStoreCount = lCount
ReDim m_cStoredMenu(1 To m_iStoreCount) As pcStoreMenu
For i = 1 To m_iStoreCount
Set m_cStoredMenu(i) = New pcStoreMenu
If Not (m_cStoredMenu(i).Deserialise(iUseFile)) Then
bFail = True
sError = m_cStoredMenu(i).Error
Exit For
End If
Next i
End If
If iFile = -1 Then
Close #iUseFile
End If
iUseFile = 0
If bFail Then
Err.Raise 9, App.EXEName & ".cPopupMenu", sError
Else
RestoreFromFile = True
End If
Else
If iFile = -1 Then
Close #iUseFile
End If
iUseFile = 0
Err.Raise 9, App.EXEName & ".cPopupMenu", "Not a cNewMenu file stream."
End If
Exit Function
ErrorHandler:
Dim lErr As Long, sErr As String
lErr = Err.Number: sErr = Err.Description
If iUseFile > 0 And iFile = -1 Then
Close #iUseFile
iUseFile = 0
End If
Err.Raise lErr, App.EXEName & ".cPopupMenu", sErr
Exit Function
Resume 0
End Function
Private Property Get plStored(ByVal sKey As String) As Long
Dim i As Long
For i = 1 To m_iStoreCount
If (m_cStoredMenu(i).Key = sKey) Then
plStored = i
Exit For
End If
Next i
End Property
Public Property Get hWndOwner() As Long
Attribute hWndOwner.VB_Description = "Sets the owning window of the popup menu.
This must be set before any popup menus are shown."
hWndOwner = m_hWndOwner
End Property
Public Property Let hWndOwner(ByVal hWndA As Long)
' Clear up:
Clear
' Set for new owner:
m_hWndOwner = hWndA
End Property
Public Property Let ImageList( _
ByRef vImageList As Variant _
)
Attribute ImageList.VB_Description = "Associates an ImageList with the Popup
menu for setting icons. This may be set to either a VB ImageList control or a
hImageList API handle."
m_hIml = 0
m_ptrVb6ImageList = 0
If (VarType(vImageList) = vbLong) Then
' Assume a handle to an image list:
m_hIml = vImageList
ElseIf (VarType(vImageList) = vbObject) Then
' Assume a VB image list:
On Error Resume Next
' Get the image list initialised..
vImageList.ListImages(1).Draw 0, 0, 0, 1
m_hIml = vImageList.hImageList
If (Err.Number = 0) Then
' Check for VB6 image list:
If (TypeName(vImageList) = "ImageList") Then
If (vImageList.ListImages.Count <>
ImageList_GetImageCount(m_hIml)) Then
Dim o As Object
Set o = vImageList
m_ptrVb6ImageList = ObjPtr(o)
End If
End If
Else
pErr "Failed to Get Image list Handle"
End If
On Error GoTo 0
End If
If (m_hIml <> 0) Then
If (m_ptrVb6ImageList <> 0) Then
m_lIconSize = vImageList.ImageHeight
Else
Dim rc As RECT
ImageList_GetImageRect m_hIml, 0, rc
m_lIconSize = rc.bottom - rc.top
End If
End If
End Property
Public Function AddItem( _
ByVal sCaption As String, _
Optional ByVal sHelptext As String = "", _
Optional ByVal lItemData As Long = 0, _
Optional ByVal lParentIndex As Long = 0, _
Optional ByVal lIconIndex As Long = -1, _
Optional ByVal bChecked As Boolean = False, _
Optional ByVal bEnabled As Boolean = True, _
Optional ByVal sKey As String = "" _
) As Long
Attribute AddItem.VB_Description = "Adds a new menu item, optionally specifying
the caption, helptext, 0 based icon index in the ImageList, Itemdata, Key to
refer to the item and whether the menu item is enabled or checked. The item
can be in a sub-menu if you specify the index of the par"
Dim lID As Long
m_iMenuCount = m_iMenuCount + 1
ReDim Preserve m_tMI(1 To m_iMenuCount) As tMenuItem
lID = plGetNewID()
With m_tMI(m_iMenuCount)
.lID = lID
.lActualID = lID
pSetMenuCaption m_iMenuCount, sCaption, (sCaption = "-")
.sAccelerator = psExtractAccelerator(sCaption)
.sHelptext = sHelptext
.lIconIndex = lIconIndex
If (lParentIndex <> 0) Then
.lParentId = m_tMI(lParentIndex).lActualID
End If
.lParentIndex = lParentIndex
.lItemData = lItemData
.bChecked = bChecked
.bEnabled = bEnabled
.bCreated = True
.bVisible = True
.bComboBox = False
.bTextBox = False
.bDragOff = False
.bInfrequent = False
.bChevronBehaviour = False
.bChevronAppearance = False
.bShowCheckAndIcon = False
.sKey = sKey
End With
pAddNewMenuItem m_tMI(m_iMenuCount)
If (m_tMI(m_iMenuCount).bTitle) Then
Header(m_iMenuCount) = True
m_tMI(m_iMenuCount).lHeight = (m_lMenuItemHeight + 6) * 3 \ 4
Else
If (m_tMI(m_iMenuCount).sCaption = "-") Then
m_tMI(m_iMenuCount).lHeight = 6
Else
m_tMI(m_iMenuCount).lHeight = m_lMenuItemHeight + 6
End If
End If
ItemData(m_iMenuCount) = lItemData
AddItem = m_iMenuCount
End Function
Public Function InsertItem( _
ByVal sCaption As String, _
ByVal vKeyBefore As Variant, _
Optional ByVal sHelptext As String = "", _
Optional ByVal lItemData As Long = 0, _
Optional ByVal lIconIndex As Long = -1, _
Optional ByVal bChecked As Boolean = False, _
Optional ByVal bEnabled As Boolean = True, _
Optional ByVal sKey As String = "" _
) As Long
Attribute InsertItem.VB_Description = "Similar to AddItem, except allows you to
Insert a menu item before an existing one rather than adding to the end of a
menu."
Dim lIndexBefore As Long
Dim lID As Long
'Inserts an item into a menu:
lIndexBefore = plMenuIndex(vKeyBefore)
If (lIndexBefore > 0) Then
m_iMenuCount = m_iMenuCount + 1
ReDim Preserve m_tMI(1 To m_iMenuCount) As tMenuItem
lID = plGetNewID()
With m_tMI(m_iMenuCount)
.lID = lID
.lActualID = lID
pSetMenuCaption m_iMenuCount, sCaption, (sCaption = "-")
.sAccelerator = psExtractAccelerator(sCaption)
.sHelptext = sHelptext
.lIconIndex = lIconIndex
.lItemData = lItemData
.bChecked = bChecked
.bEnabled = bEnabled
.bCreated = True
.bVisible = True
.bComboBox = False
.bTextBox = False
.bDragOff = False
.bInfrequent = False
.bChevronAppearance = False
.bChevronBehaviour = False
.bShowCheckAndIcon = False
.sKey = sKey
End With
pInsertNewMenuitem m_tMI(m_iMenuCount), lIndexBefore
InsertItem = m_iMenuCount
End If
End Function
Public Function ReplaceItem( _
ByVal vKey As Variant, _
Optional ByVal sCaption As Variant, _
Optional ByVal sHelptext As Variant, _
Optional ByVal lItemData As Variant, _
Optional ByVal lIconIndex As Variant, _
Optional ByVal bChecked As Variant, _
Optional ByVal bEnabled As Variant _
) As Long
Attribute ReplaceItem.VB_Description = "Replaces one or more properties of an
existing menu item."
Dim lIndex As Long
Dim sItems() As String
Dim lH() As Long
Dim lR As Long
Dim lFlags As Long
Dim lPosition As Long
Dim tMI As MENUITEMINFO
Dim hSubMenu As Long
' Replaces a menu item with a new one. Works
' around a bug with the caption property where if
' you changed the size of the caption the menu did
' not resize. Also allows you to change the help
' text, item data, icon, check and enable at the
' same time.
' Check valid index:
lIndex = plMenuIndex(vKey)
If (lIndex > 0) Then
If Not IsMissing(sCaption) Then
pSetMenuCaption lIndex, sCaption, (sCaption = "-")
End If
If Not IsMissing(sHelptext) Then
m_tMI(lIndex).sHelptext = sHelptext
End If
If Not IsMissing(lItemData) Then
m_tMI(lIndex).lItemData = lItemData
End If
If Not IsMissing(lIconIndex) Then
m_tMI(lIndex).lIconIndex = lIconIndex
End If
If Not IsMissing(bChecked) Then
m_tMI(lIndex).bChecked = bChecked
End If
If Not IsMissing(bEnabled) Then
m_tMI(lIndex).bEnabled = bEnabled
End If
pHierarchyForIndex lIndex, lH(), sItems()
lPosition = lH(UBound(lH)) - 1
' Check if there is a sub menu:
tMI.cbSize = Len(tMI)
tMI.fMask = MIIM_SUBMENU
GetMenuItemInfo m_tMI(lIndex).hMenu, m_tMI(lIndex).lActualID, 0, tMI
hSubMenu = tMI.hSubMenu
' Remove the menu item:
lR = RemoveMenu(m_tMI(lIndex).hMenu, m_tMI(lIndex).lActualID,
MF_BYCOMMAND)
' Insert it back again at the corect position with the same ID etc:
lFlags = plMenuFlags(lIndex)
lFlags = (lFlags Or MF_OWNERDRAW) And Not MF_STRING Or MF_BYPOSITION
lR = InsertMenuByLong(m_tMI(lIndex).hMenu, lPosition, lFlags,
m_tMI(lIndex).lID, m_tMI(lIndex).lID)
If (hSubMenu <> 0) Then
' If we had a submenu then put that back again:
lFlags = lFlags And Not MF_BYPOSITION Or MF_BYCOMMAND
lFlags = lFlags Or MF_POPUP
lR = ModifyMenuByLong(m_tMI(lIndex).hMenu, m_tMI(lIndex).lID, lFlags,
hSubMenu, m_tMI(lIndex).lActualID)
End If
If (lR = 0) Then
pErr "Failed to insert new menu item."
End If
End If
End Function
Public Sub RemoveItem( _
ByVal vKey As Variant _
)
Attribute RemoveItem.VB_Description = "Removes an item from a menu, and any
sub-items of that item."
Dim lIndex As Long
lIndex = IndexForKey(vKey)
If (lIndex > 0) Then
pRemoveItem lIndex
End If
End Sub
Private Sub pRemoveItem( _
ByVal lIndex As Long _
)
Dim hMenusToDestroy() As Long
Dim lCount As Long
Dim lDestroy As Long
Dim lRealCount As Long
Dim lR As Long
Dim lMaxID As Long
Dim lSubIndex As Long
Dim lNew() As Long
' Remove the Item:
lR = RemoveMenu(m_tMI(lIndex).hMenu, m_tMI(lIndex).lActualID, MF_BYCOMMAND)
m_tMI(lIndex).bMarkToDestroy = True
' Loop though all the children of the item at Index and determine
' what there is to remove:
pRemoveSubMenus m_tMI(lIndex).lActualID, 1, hMenusToDestroy(), lCount
' Destroy the menus:
For lDestroy = 1 To lCount
DestroyMenu hMenusToDestroy(lDestroy)
' Debug.Print "Destroyed sub-menu:" & hMenusToDestroy(lDestroy)
Next lDestroy
' Now repopulate the array & sort out the indexes to remove
' the indexes marked for deletion:
If (lCount > 0) Or (lR <> 0) Then
lRealCount = 0
For lIndex = 1 To m_iMenuCount
If Not (m_tMI(lIndex).bMarkToDestroy) Then
If (GetMenuItemCount(m_tMI(lIndex).lActualID) = -1) Then
If (m_tMI(lIndex).lActualID > lMaxID) Then
lMaxID = m_tMI(lIndex).lActualID
End If
End If
lRealCount = lRealCount + 1
If (lRealCount <> lIndex) Then
' A much neater way than previously (set all the items
independently!
' what was I thinking of)
LSet m_tMI(lRealCount) = m_tMI(lIndex)
' problem: the parent index of a menu is now changed by the
modification:
For lSubIndex = 1 To m_iMenuCount
If m_tMI(lSubIndex).lParentIndex = lIndex Then
m_tMI(lSubIndex).lParentIndex = lRealCount
m_tMI(lSubIndex).lParentId = m_tMI(lRealCount).lActualID
End If
Next lSubIndex
End If
End If
Next lIndex
ReDim Preserve m_tMI(1 To lRealCount) As tMenuItem
m_iMenuCount = lRealCount
If (lMaxID > m_iMenuCount) Then
m_lLastMaxId = lMaxID
Else
m_lLastMaxId = m_iMenuCount
End If
End If
End Sub
Private Sub pRemoveSubMenus( _
ByVal lParentId As Long, _
ByVal lStartIndex As Long, _
ByRef hMenusToDestroy() As Long, _
ByRef lMenuToDestroyCount As Long _
)
Dim lIndex As Long
For lIndex = 1 To m_iMenuCount
If (m_tMI(lIndex).lParentId = lParentId) Then
m_tMI(lIndex).bMarkToDestroy = True
pAddToDestroyArray m_tMI(lIndex).hMenu, hMenusToDestroy(),
lMenuToDestroyCount
pRemoveSubMenus m_tMI(lIndex).lActualID, lIndex, hMenusToDestroy(),
lMenuToDestroyCount
End If
Next lIndex
End Sub
Private Sub pAddToDestroyArray( _
ByVal hMenu As Long, _
ByRef hMenusToDestroy() As Long, _
ByRef lMenuToDestroyCount As Long _
)
Dim lIndex As Long
Dim bFound As Boolean
For lIndex = 1 To lMenuToDestroyCount
If (hMenusToDestroy(lIndex) = hMenu) Then
bFound = True
Exit For
End If
Next lIndex
If Not (bFound) Then
lMenuToDestroyCount = lMenuToDestroyCount + 1
ReDim Preserve hMenusToDestroy(1 To lMenuToDestroyCount) As Long
hMenusToDestroy(lMenuToDestroyCount) = hMenu
End If
End Sub
Public Function ClearSubMenusOfItem( _
ByVal vKey As Variant _
) As Long
Attribute ClearSubMenusOfItem.VB_Description = "Removes all the sub menus items
of a given parent menu item, but leaves the sub menu itself. Use when
responding to the InitPopupMenu event."
Dim hMenu As Long
Dim iMenu As Long
Dim lIndex As Long
lIndex = plMenuIndex(vKey)
If (lIndex > 0) Then
' The idea is to leave just the submenu
' but with nothing in it:
' The ActualID of a sub-menu will be the
' handle to the submenu:
hMenu = m_tMI(lIndex).lActualID
' Now remove all the items in the sub-menu,
' mark them for destruction and also do
' any sub-menus they may have:
For iMenu = m_iMenuCount To 1 Step -1
If (iMenu <= m_iMenuCount) Then
If (m_tMI(iMenu).hMenu = hMenu) Then
pRemoveItem iMenu
End If
End If
Next iMenu
For iMenu = 1 To m_iMenuCount
If (m_tMI(iMenu).lActualID = hMenu) Then
ClearSubMenusOfItem = iMenu
Exit For
End If
Next iMenu
End If
End Function
Private Sub pInsertNewMenuitem( _
ByRef tMI As tMenuItem, _
ByVal lIndexBefore As Long _
)
Dim lPIndex As Long
Dim hMenu As Long
Dim lFlags As Long
Dim lPosition As Long
Dim lR As Long
Dim lH() As Long
Dim sItems() As String
' Find out where we're inserting into existing sub menu:
hMenu = m_tMI(lIndexBefore).hMenu
If (hMenu <> 0) Then
pHierarchyForIndex lIndexBefore, lH(), sItems()
lPosition = lH(UBound(lH)) - 1
lFlags = plMenuFlags(m_iMenuCount)
lFlags = (lFlags Or MF_OWNERDRAW) And Not MF_STRING Or MF_BYPOSITION
lR = InsertMenuByLong(hMenu, lPosition, lFlags, tMI.lID, tMI.lID)
If (lR = 0) Then
pErr "Failed to insert new Menu item"
Else
' Store the hMenu for this item:
tMI.hMenu = hMenu
End If
End If
End Sub
Private Sub pSetMenuCaption( _
ByVal iItem As Long, _
ByVal sCaption As String, _
ByVal bSeparator As Boolean _
)
Dim sCap As String
Dim sShortCut As String
Dim iPos As Long
m_tMI(iItem).sInputCaption = sCaption
If (bSeparator) Then
m_tMI(iItem).sCaption = "-"
Else
' Check if this is a title:
If (left$(sCaption, 1) = "-") Then
m_tMI(iItem).bTitle = True
sCaption = Mid$(sCaption, 2)
End If
' Check if this menu item will have a menu bar break:
pParseCaption sCaption, "|", m_tMI(iItem).bMenuBarBreak
' Check if this menu item will be on the same line as
' the last one:
pParseCaption sCaption, "^", m_tMI(iItem).bMenuBreak
' Check if we have a shortcut to the menu item:
iPos = InStr(sCaption, vbTab)
If (iPos <> 0) Then
sCap = left$(sCaption, (iPos - 1))
' Extract the ctrl key item:
sShortCut = Mid$(sCaption, (iPos + 1))
pParseMenuShortcut iItem, sShortCut
Else
sCap = sCaption
End If
m_tMI(iItem).sAccelerator = psExtractAccelerator(sCap)
m_tMI(iItem).sCaption = sCap
End If
End Sub
Private Sub pParseCaption(ByRef sCaption As String, ByVal sToken As String,
ByRef bFlag As Boolean)
Dim iPos As Long
Dim iPos2 As Long
Dim sCap As String
iPos = InStr(sCaption, sToken)
If (iPos <> 0) Then
' Check for double token (i.e. interpret as untokenised character):
iPos2 = InStr(sCaption, sToken & sToken)
If (iPos2 <> 0) Then
bFlag = False
If (iPos2 > 1) Then
sCap = left$(sCaption, iPos - 1)
End If
If (iPos2 + 1 < Len(sCaption)) Then
sCap = sCap & Mid$(sCaption, iPos2 + 1)
End If
Else
bFlag = True
If (iPos > 1) Then
sCap = left$(sCaption, iPos - 1)
End If
If (iPos < Len(sCaption)) Then
sCap = sCap & Mid$(sCaption, iPos + 1)
End If
sCaption = sCap
End If
Else
bFlag = False
End If
End Sub
Private Sub pParseMenuShortcut( _
ByVal iItem As Long, _
ByVal sShortCut As String _
)
Dim iPos As Long
Dim iNextPos As Long
Dim iCount As Long
Dim sBits() As String
Dim sKeyNum As String
sShortCut = Trim$(sShortCut)
m_tMI(iItem).iShortCutShiftMask = 0
m_tMI(iItem).iShortCutShiftKey = 0
m_tMI(iItem).sShortCutDisplay = sShortCut
If Len(sShortCut) > 0 Then
iPos = 1
iNextPos = InStr(iPos, sShortCut, "+")
Do While iNextPos <> 0
iCount = iCount + 1
ReDim Preserve sBits(1 To iCount) As String
sBits(iCount) = Mid$(sShortCut, iPos, iNextPos - iPos)
iPos = iNextPos + 1
iNextPos = InStr(iPos, sShortCut, "+")
Loop
If iPos <= Len(sShortCut) Then
iCount = iCount + 1
ReDim Preserve sBits(1 To iCount) As String
sBits(iCount) = Mid$(sShortCut, iPos)
End If
' Parse the bits:
For iPos = 1 To iCount
If Len(sBits(iPos)) = 1 Then
m_tMI(iItem).iShortCutShiftKey = Asc(UCase$(sBits(iPos)))
Else
Select Case sBits(iPos)
Case "Ctrl"
m_tMI(iItem).iShortCutShiftMask =
m_tMI(iItem).iShortCutShiftMask Or vbCtrlMask
Case "Alt"
m_tMI(iItem).iShortCutShiftMask =
m_tMI(iItem).iShortCutShiftMask Or vbAltMask
Case "Shift"
m_tMI(iItem).iShortCutShiftMask =
m_tMI(iItem).iShortCutShiftMask Or vbShiftMask
Case "Home"
m_tMI(iItem).iShortCutShiftKey = vbKeyHome
Case "End"
m_tMI(iItem).iShortCutShiftKey = vbKeyEnd
Case "Left Arrow"
m_tMI(iItem).iShortCutShiftKey = vbKeyLeft
Case "Right Arrow"
m_tMI(iItem).iShortCutShiftKey = vbKeyRight
Case "Up Arrow"
m_tMI(iItem).iShortCutShiftKey = vbKeyUp
Case "Down Arrow"
m_tMI(iItem).iShortCutShiftKey = vbKeyDown
Case "Break"
m_tMI(iItem).iShortCutShiftKey = vbKeyClear
Case "Page Up"
m_tMI(iItem).iShortCutShiftKey = vbKeyPageUp
Case "Page Up"
m_tMI(iItem).iShortCutShiftKey = vbKeyPageDown
Case "Del"
m_tMI(iItem).iShortCutShiftKey = vbKeyDelete
Case "Esc"
m_tMI(iItem).iShortCutShiftKey = vbKeyEscape
Case "Tab"
m_tMI(iItem).iShortCutShiftKey = vbKeyTab
Case "Enter"
m_tMI(iItem).iShortCutShiftKey = vbKeyReturn
Case Else
If left$(sShortCut, 1) = "F" Then
sKeyNum = Mid$(sShortCut, (iPos + 1))
m_tMI(iItem).iShortCutShiftKey = vbKeyF1 + Val(sKeyNum) - 1
End If
End Select
End If
Next iPos
End If
End Sub
Private Function pHierarchyForIndex( _
ByVal lIndex As Long, _
ByRef lHierarchy() As Long, _
ByRef sItems() As String _
) As String
Dim lH() As Long
Dim sI() As String
Dim lItems As Long
Dim hMenuSeek As Long
Dim lPid As Long
Dim bComplete As Boolean
Dim l As Long
Dim lNewIndex As Long
Dim sOut As String
Erase lHierarchy
Erase sItems
' Now determine the hierarchy for this item:
hMenuSeek = m_tMI(lIndex).hMenu
Do
lItems = lItems + 1
ReDim Preserve lH(1 To lItems) As Long
ReDim Preserve sI(1 To lItems) As String
lH(lItems) = plMenuPositionForIndex(hMenuSeek, lIndex)
sI(lItems) = m_tMI(lIndex).sCaption
lPid = m_tMI(lIndex).lParentId
If (lPid <> 0) Then
lNewIndex = plGetIndexForId(m_tMI(lIndex).lParentId)
' Debug.Print lNewIndex
lIndex = lNewIndex
hMenuSeek = m_tMI(lIndex).hMenu
Else
bComplete = True
End If
Loop While Not (bComplete)
ReDim lHierarchy(1 To lItems) As Long
ReDim sItems(1 To lItems) As String
For l = lItems To 1 Step -1
lHierarchy(l) = lH(lItems - l + 1)
sItems(l) = sI(lItems - l + 1)
Next l
End Function
Private Function plMenuPositionForIndex( _
ByVal hMenuSeek As Long, _
ByVal lIndex As Long _
) As Long
Dim l As Long
Dim lPos As Long
Dim tMII As MENUITEMINFO
Dim lCount As Long
' fixed bug where this returned the wrong menu item...
lCount = GetMenuItemCount(hMenuSeek)
If (lCount > 0) Then
For l = 0 To lCount - 1
tMII.cbSize = Len(tMII)
tMII.fMask = MIIM_ID
GetMenuItemInfo hMenuSeek, l, True, tMII
If (tMII.wID = m_tMI(lIndex).lActualID) And (m_tMI(lIndex).hMenu =
hMenuSeek) Then
plMenuPositionForIndex = l + 1
End If
Next l
End If
End Function
Private Function plFindItemInMenu( _
ByVal hMenuSeek As Long, _
ByVal lPosition As Long _
) As Long
Dim lPos As Long
Dim l As Long, i As Long
Dim lID As Long
Dim lCount As Long
Dim tMII As MENUITEMINFO
' fixed bug where this returned the wrong menu item...
tMII.cbSize = Len(tMII)
tMII.fMask = MIIM_ID
GetMenuItemInfo hMenuSeek, lPosition - 1, True, tMII
For i = 1 To m_iMenuCount
If m_tMI(i).lActualID = tMII.wID And m_tMI(i).hMenu = hMenuSeek Then
plFindItemInMenu = i
Exit Function
End If
Next i
End Function
Private Function plMenuIndex(ByVal vKey As Variant) As Long
Dim i As Long
' Signal default
plMenuIndex = -1
' Check for numeric key (i.e. index):
If (IsNumeric(vKey)) Then
i = CLng(vKey)
If (i > 0) And (i <= m_iMenuCount) Then
plMenuIndex = i
End If
Else
' Check for string key:
For i = 1 To m_iMenuCount
If (m_tMI(i).sKey = vKey) Then
plMenuIndex = i
Exit Function
End If
Next i
End If
End Function
Public Property Get IndexForKey( _
ByVal sKey As String _
) As Long
Attribute IndexForKey.VB_Description = "Returns the internal index for a menu
item with the given key. If there is more than one item with the same key,
the first item found is returned."
Dim i As Long
i = plMenuIndex(sKey)
If i = -1 Then i = 0
IndexForKey = i
End Property
Public Property Get ItemKey( _
ByVal lIndex As Long _
) As String
Attribute ItemKey.VB_Description = "Gets/sets a key string to be associated
with a menu item. Keys do not have to be unique."
ItemKey = m_tMI(lIndex).sKey
End Property
Public Property Let ItemKey( _
ByVal lIndex As Long, _
ByVal sKey As String _
)
m_tMI(lIndex).sKey = sKey
End Property
Public Property Get ItemData( _
ByVal lIndex As Long _
) As Long
Attribute ItemData.VB_Description = "Gets/sets a long value associated with a
menu item."
ItemData = m_tMI(lIndex).lItemData
End Property
Public Property Get ItemParentIndex( _
ByVal lIndex As Long _
) As Long
Attribute ItemParentIndex.VB_Description = "Returns the index of the parent
item of this menu (or zero if the item has no parent)."
ItemParentIndex = m_tMI(lIndex).lParentIndex
End Property
Public Property Let ItemData( _
ByVal lIndex As Long, _
ByVal lItemData As Long _
)
Dim tMII As MENUITEMINFO
m_tMI(lIndex).lItemData = lItemData
If (lIndex > 0) And (lIndex <= m_iMenuCount) Then
tMII.cbSize = Len(tMII)
tMII.fMask = MIIM_DATA
GetMenuItemInfo m_tMI(lIndex).hMenu, m_tMI(lIndex).lActualID, False, tMII
tMII.dwItemData = lItemData
SetMenuItemInfo m_tMI(lIndex).hMenu, m_tMI(lIndex).lActualID, False, tMII
End If
End Property
Public Property Let ItemIcon( _
ByVal lIndex As Long, _
ByVal lIconIndex As Long _
)
m_tMI(lIndex).lIconIndex = lIconIndex
End Property
Public Property Get ItemIcon( _
ByVal lIndex As Long _
) As Long
Attribute ItemIcon.VB_Description = "Gets/sets the 0 based icon index of an
icon to be associated with a menu item. Set to -1 if you don't want an icon."
ItemIcon = m_tMI(lIndex).lIconIndex
End Property
Public Property Get ItemInfrequentlyUsed( _
ByVal lIndex As Long _
) As Boolean
Attribute ItemInfrequentlyUsed.VB_Description = "Gets/sets whether a menu item
should be drawn as infrequently used or not. When the HideInfrequentlyUsed
flag is set, these items will be hidden."
ItemInfrequentlyUsed = m_tMI(lIndex).bInfrequent
End Property
Public Property Let ItemInfrequentlyUsed( _
ByVal lIndex As Long, _
ByVal bState As Boolean _
)
m_tMI(lIndex).bInfrequent = bState
ResetMenuForRecalc lIndex
setInfrequentSeparatorsAndChevrons m_tMI(lIndex).hMenu
End Property
Public Property Get HideInfrequentlyUsed() As Boolean
Attribute HideInfrequentlyUsed.VB_Description = "Hides items with the
ItemInfrequentlyUsed flag set, and adds chevrons to any menus with hidden menu
items."
HideInfrequentlyUsed = Not (m_bShowInfrequent)
End Property
Public Property Let HideInfrequentlyUsed(ByVal bState As Boolean)
If (bState = m_bShowInfrequent) Then
showInfrequentlyUsed Not (bState)
End If
End Property
Public Property Get Checked( _
ByVal lIndex As Long _
) As Boolean
Dim tMII As MENUITEMINFO
tMII.fMask = MIIM_STATE
tMII.cbSize = LenB(tMII)
GetMenuItemInfo m_tMI(lIndex).hMenu, m_tMI(lIndex).lActualID, False, tMII
m_tMI(lIndex).bChecked = ((tMII.fState And MFS_CHECKED) = MFS_CHECKED)
Checked = m_tMI(lIndex).bChecked
End Property
Public Property Let Checked( _
ByVal lIndex As Long, _
ByVal bChecked As Boolean _
)
Attribute Checked.VB_Description = "Gets/sets whether a menu item is checked."
Dim lFlag As Long
Dim lFlagNot As Long
m_tMI(lIndex).bChecked = bChecked
If (bChecked) Then
lFlag = MF_CHECKED
lFlagNot = 0
Else
lFlag = 0
lFlagNot = MF_CHECKED
End If
pSetMenuFlag lIndex, lFlag, lFlagNot
End Property
Public Property Get RadioCheck(ByVal lIndex As Long) As Boolean
Attribute RadioCheck.VB_Description = "Gets/sets whether a menu item is checked
with a radio (option-box) style indicator."
' BMS 19/9/99: Added Property Get RadioChecked, to allow client to
' determine if an item is of type RadioCheck or not.
If (lIndex > 0) Then
RadioCheck = m_tMI(lIndex).bRadioCheck
End If
End Property
Public Property Let RadioCheck( _
ByVal lIndex As Long, _
ByVal bRadioCheck As Boolean _
)
' BMS 20/9/99: Added Property Let RadioChecked, to allow client to
' set if an item is of type RadioCheck or not.
Dim lFlag As Long
Dim lFlagNot As Long
If bRadioCheck Then
If m_tMI(lIndex).bChecked Then
Checked(lIndex) = False
End If
End If
m_tMI(lIndex).bRadioCheck = bRadioCheck
If (bRadioCheck) Then
lFlag = MFT_RADIOCHECK
lFlagNot = 0
Else
lFlag = 0
lFlagNot = MFT_RADIOCHECK
End If
pSetMenuFlag lIndex, lFlag, lFlagNot
End Property
Public Property Get ShowCheckAndIcon(ByVal lIndex As Long) As Boolean
Attribute ShowCheckAndIcon.VB_Description = "Gets/sets whether to show the icon
separately from the check box for this menu item. Use to create menus like the
Office XP Add/Remove button menu."
ShowCheckAndIcon = m_tMI(lIndex).bShowCheckAndIcon
End Property
Public Property Let ShowCheckAndIcon(ByVal lIndex As Long, ByVal bState As
Boolean)
m_tMI(lIndex).bShowCheckAndIcon = bState
ResetMenuForRecalc lIndex
End Property
Public Property Get RedisplayMenuOnClick(ByVal lIndex As Long) As Boolean
Attribute RedisplayMenuOnClick.VB_Description = "Gets/sets whether the menu
will be immediately re-displayed once it has been clicked. Use this style to
create option menus such as the Add/Remove buttons menu in Office
applications."
RedisplayMenuOnClick = m_tMI(lIndex).bChevronBehaviour
End Property
Public Property Let RedisplayMenuOnClick(ByVal lIndex As Long, ByVal bState As
Boolean)
m_tMI(lIndex).bChevronBehaviour = bState
End Property
Public Sub GroupToggle(ByVal lIndex As Long, Optional ByVal bRadio As Boolean =
True)
Attribute GroupToggle.VB_Description = "Toggles the value of one radio item
within a group (between separators within the same menu)"
Dim hMenuSeek As Long
Dim lPos As Long
Dim l As Long
Dim lCount As Long
Dim tMII As MENUITEMINFO
' Check a radio item and toggle off any others within
' this menu space:
If lIndex > 0 And lIndex <= m_iMenuCount Then
RadioCheck(lIndex) = True
hMenuSeek = m_tMI(lIndex).hMenu
lPos = plMenuPositionForIndex(hMenuSeek, lIndex) - 1
If lPos > -1 Then
For l = lPos - 1 To 0 Step -1
tMII.cbSize = Len(tMII)
tMII.fMask = MIIM_ID Or MIIM_TYPE
GetMenuItemInfo hMenuSeek, l, True, tMII
If (tMII.fType And MF_SEPARATOR) <> MF_SEPARATOR Then
lIndex = plGetIndexForId(tMII.wID)
RadioCheck(lIndex) = False
Else
Exit For
End If
Next l
For l = lPos + 1 To GetMenuItemCount(hMenuSeek) - 1
tMII.cbSize = Len(tMII)
tMII.fMask = MIIM_TYPE Or MIIM_ID
GetMenuItemInfo hMenuSeek, l, True, tMII
If (tMII.fType And MF_SEPARATOR) <> MF_SEPARATOR Then
lIndex = plGetIndexForId(tMII.wID)
RadioCheck(lIndex) = False
Else
Exit For
End If
Next l
End If
End If
End Sub
Public Property Get Enabled( _
ByVal lIndex As Long _
) As Boolean
Attribute Enabled.VB_Description = "Gets/sets whether an item in a popup menu
is enabled."
Enabled = m_tMI(lIndex).bEnabled
End Property
Public Property Let Enabled( _
ByVal lIndex As Long, _
ByVal bEnabled As Boolean _
)
Dim lFlag As Long
Dim lFlagNot As Long
m_tMI(lIndex).bEnabled = bEnabled
If (bEnabled) Then
lFlag = MF_ENABLED
lFlagNot = MF_GRAYED
Else
lFlag = MF_DISABLED
lFlagNot = MF_GRAYED
End If
pSetMenuFlag lIndex, lFlag, lFlagNot
End Property
Public Property Get Caption( _
ByVal lIndex As Long _
) As String
Attribute Caption.VB_Description = "Gets/sets the caption for a menu item."
Caption = m_tMI(lIndex).sCaption
End Property
Public Property Let Caption( _
ByVal lIndex As Long, _
ByVal sCaption As String _
)
m_tMI(lIndex).sInputCaption = sCaption
m_tMI(lIndex).sCaption = sCaption
m_tMI(lIndex).sAccelerator = psExtractAccelerator(sCaption)
ResetMenuForRecalc lIndex
End Property
Public Property Get Visible( _
ByVal lIndex As Long _
) As Boolean
Attribute Visible.VB_Description = "Gets/sets whether a menu item is displayed
or not."
Visible = m_tMI(lIndex).bVisible
End Property
Public Property Let Visible( _
ByVal lIndex As Long, _
ByVal bState As Boolean _
)
m_tMI(lIndex).bVisible = bState
ResetMenuForRecalc lIndex
End Property
Public Property Get HelpText( _
ByVal lIndex As Long _
) As String
HelpText = m_tMI(lIndex).sHelptext
End Property
Public Property Let HelpText( _
ByVal lIndex As Long, _
ByVal sHelptext As String _
)
Attribute HelpText.VB_Description = "Gets/sets the helptext associated with an
item."
m_tMI(lIndex).sHelptext = sHelptext
End Property
Private Sub showInfrequentlyUsed(ByVal bState As Boolean)
Dim i As Long
Dim bChange As Boolean
bChange = Not (m_bShowInfrequent = bState)
' set the state (if not already...)
m_bShowInfrequent = bState
' Debug.Print "showInfrequentyUsed:", bState
If (bChange) Or (Not m_bShowInfrequent) Then
' ensure all items get measured correctly:
For i = 1 To m_iMenuCount
If m_tMI(i).bInfrequent Then
ResetMenuForRecalc i
End If
Next i
'
If Not (bState) Then
' which menus should we add chevrons to?
' which separators should we also set as infrequent?
Dim hMenu() As Long
Dim iMenuCount As Long
Dim j As Long
Dim lIndex As Long
' determine which menus contain infrequent items:
For i = 1 To m_iMenuCount
lIndex = 0
For j = 1 To iMenuCount
If lIndex = 0 Then
If m_tMI(i).hMenu = hMenu(j) Then
lIndex = j
Exit For
End If
End If
Next j
If (lIndex = 0) Then
ReDim Preserve hMenu(1 To iMenuCount + 1) As Long
iMenuCount = iMenuCount + 1
hMenu(iMenuCount) = m_tMI(i).hMenu
End If
Next i
' correct separators & add chevrons:
For j = 1 To iMenuCount
setInfrequentSeparatorsAndChevrons hMenu(j)
Next j
' done.
Else
' remove chevrons:
For i = m_iMenuCount To 1 Step -1
If i <= m_iMenuCount Then
If m_tMI(i).bChevronAppearance Then
pRemoveItem i
End If
End If
Next i
End If
End If
End Sub
Private Sub setInfrequentSeparatorsAndChevrons(ByVal hMenu As Long)
Dim i As Long
Dim iCount As Long
Dim tMI As MENUITEMINFO
Dim lIndex As Long
Dim lGroupFrequentCount As Long
Dim lInFrequentCount As Long
Dim lParentIndex As Long
Dim bSeparator As Boolean
Dim sKey As String
Dim lR As Long
tMI.cbSize = LenB(tMI)
tMI.fMask = MIIM_ID
iCount = GetMenuItemCount(hMenu)
For i = 1 To iCount
lR = GetMenuItemInfo(hMenu, i - 1, True, tMI)
lIndex = ItemForID(tMI.wID)
If lIndex > 0 Then
bSeparator = isSeparator(lIndex)
If bSeparator Then
m_tMI(lIndex).bInfrequent = (lGroupFrequentCount = 0)
lGroupFrequentCount = 0
Else
If m_tMI(lIndex).bInfrequent Then
lInFrequentCount = lInFrequentCount + 1
lParentIndex = m_tMI(lIndex).lParentIndex
Else
lGroupFrequentCount = lGroupFrequentCount + 1
End If
End If
End If
Next i
' remove chevrons:
sKey = m_sCurrentlyRestoredKey
m_sCurrentlyRestoredKey = ""
For i = m_iMenuCount To 1 Step -1
If i <= m_iMenuCount Then
If m_tMI(i).hMenu = hMenu Then
If m_tMI(i).bChevronAppearance Then
pRemoveItem i
End If
End If
End If
Next i
m_sCurrentlyRestoredKey = sKey
If (lInFrequentCount > 0) And Not (m_bShowInfrequent) Then
i = AddItem("v-chevron-v", , , lParentIndex)
m_tMI(i).bChevronAppearance = True
m_tMI(i).bChevronBehaviour = True
ItemData(i) = &HCAFECAFE
End If
End Sub
Private Function isSeparator(ByVal lIndex As Long) As Boolean
If Trim$(m_tMI(lIndex).sCaption = "-") Then
isSeparator = True
End If
End Function
Private Sub ResetMenuForRecalc(ByVal lIndex As Long)
Dim tMI As MENUITEMINFO
Dim hMenu As Long
Dim hSubMenu As Long
Dim lFlags As Long
Dim lR As Long
Dim lPosition As Long
Dim iCount As Long, i As Long
' Modify the menu item:
hMenu = m_tMI(lIndex).hMenu
tMI.cbSize = Len(tMI)
tMI.fMask = MIIM_SUBMENU
GetMenuItemInfo hMenu, m_tMI(lIndex).lActualID, 0, tMI
hSubMenu = tMI.hSubMenu
iCount = GetMenuItemCount(hMenu)
tMI.fMask = MIIM_ID
For i = 0 To iCount - 1
GetMenuItemInfo hMenu, i, 1, tMI
If (tMI.wID <> m_tMI(lIndex).lActualID) Then
lPosition = lPosition + 1
Else
Exit For
End If
Next i
' remove it from the menu:
RemoveMenu hMenu, m_tMI(lIndex).lActualID, MF_BYCOMMAND
' Insert it back again at the corect position with the same ID etc:
lFlags = plMenuFlags(lIndex)
lFlags = (lFlags Or MF_OWNERDRAW) And Not MF_STRING Or MF_BYPOSITION
lR = InsertMenuByLong(m_tMI(lIndex).hMenu, lPosition, lFlags,
m_tMI(lIndex).lID, m_tMI(lIndex).lItemData)
If (hSubMenu <> 0) Then
' If we had a submenu then put that back again:
lFlags = lFlags And Not MF_BYPOSITION Or MF_BYCOMMAND
lFlags = lFlags Or MF_POPUP
lR = ModifyMenuByLong(m_tMI(lIndex).hMenu, m_tMI(lIndex).lID, lFlags,
hSubMenu, m_tMI(lIndex).lItemData)
End If
End Sub
Public Property Get Header( _
ByVal lIndex As Long _
) As Boolean
Attribute Header.VB_Description = "Gets/sets whether a menu item is drawn as a
Text Header. Same as setting the first character of the menu item's caption
to ""-""."
Header = m_tMI(lIndex).bTitle
End Property
Public Property Let Header( _
ByVal lIndex As Long, _
ByVal bState As Boolean _
)
m_tMI(lIndex).bTitle = bState
If (bState) Then
If Not m_tMI(lIndex).bDragOff Then
' disable the item
pSetMenuFlag lIndex, MF_DISABLED, MF_GRAYED
Else
' neither disabled nor grayed
pSetMenuFlag lIndex, 0, MF_DISABLED Or MF_GRAYED
End If
End If
End Property
Public Property Get OwnerDraw( _
ByVal lIndex As Long _
) As Boolean
Attribute OwnerDraw.VB_Description = "Gets/sets whether the control should
raise MeasureItem and DrawItem events before it is drawn, allowing you to
override the default drawing style."
OwnerDraw = m_tMI(lIndex).bOwnerDraw
End Property
Public Property Let OwnerDraw( _
ByVal lIndex As Long, _
ByVal bState As Boolean _
)
m_tMI(lIndex).bOwnerDraw = bState
End Property
Public Property Get Default( _
ByVal lIndex As Long _
) As Boolean
Attribute Default.VB_Description = "Gets/sets whether a menu item is drawn as a
default selection (bolded)."
Default = m_tMI(lIndex).bDefault
End Property
Public Property Let Default( _
ByVal lIndex As Long, _
ByVal bState As Boolean _
)
m_tMI(lIndex).bDefault = bState
' Modify this menu item to reflect the new properties:
ResetMenuForRecalc lIndex
End Property
Public Sub Clear()
Attribute Clear.VB_Description = "Removes all menu items and clears up any
resources associated with them."
Dim lMenu As Long
m_lLastMaxId = &H800
' Clear up all submenus we have created:
For lMenu = 1 To m_lSubMenuCount
DestroyMenu m_hSubMenus(lMenu)
Next lMenu
m_lSubMenuCount = 0
Erase m_hSubMenus
' Clear the main menu we have created:
If (m_iMenuCount > 0) Then
DestroyMenu m_tMI(1).hMenu
End If
' Clear up the array:
m_iMenuCount = 0
Erase m_tMI
End Sub
Public Function ShowPopupMenu( _
ByVal lLeft As Long, _
ByVal lTop As Long, _
Optional ByVal lExcludeLeft As Long = 0, _
Optional ByVal lExcludeTop As Long = 0, _
Optional ByVal lExcludeRight As Long = 0, _
Optional ByVal lExcludeBottom As Long = 0, _
Optional ByVal bTryToKeepLeft As Boolean = True _
) As Long
Attribute ShowPopupMenu.VB_Description = "Shows the current Popup menu. This
function returns the selected menu item index or 0 if nothing was selected."
Dim tP As POINTAPI
Dim tP2 As POINTAPI
Dim tPM As TPMPARAMS
Dim lR As Long
Dim lIndex As Long
Dim i As Long
Dim lUN As Long
Dim bIsSubclass As Boolean
If Count = 0 Then
Exit Function
End If
tP.x = lLeft \ Screen.TwipsPerPixelX
tP.y = lTop \ Screen.TwipsPerPixelY
ClientToScreen m_hWndOwner, tP
If Abs(lExcludeLeft - lExcludeRight) > 0 Or Abs(lExcludeTop -
lExcludeBottom) > 0 Then
tP2.x = lExcludeLeft \ Screen.TwipsPerPixelX
tP2.y = lExcludeTop \ Screen.TwipsPerPixelY
ClientToScreen m_hWndOwner, tP2
tPM.rcExclude.left = tP2.x
tPM.rcExclude.top = tP2.y
tP2.x = lExcludeRight \ Screen.TwipsPerPixelX
tP2.y = lExcludeBottom \ Screen.TwipsPerPixelY
ClientToScreen m_hWndOwner, tP2
tPM.rcExclude.right = tP2.x
tPM.rcExclude.bottom = tP2.y
End If
tPM.cbSize = Len(tPM)
lUN = TPM_RETURNCMD
If Not (bTryToKeepLeft) Then
lUN = lUN Or TPM_VERTICAL
End If
If (m_bNoAnimation) Then
lUN = lUN Or TPM_NOANIMATION
End If
SendMessageLong m_hWndOwner, WM_ENTERMENULOOP, 1, 0
bIsSubclass = (m_hWndAttached <> 0)
showInfrequentlyUsed m_bShowInfrequent
CreateSubClass m_hWndOwner
lR = TrackPopupMenuEx(m_tMI(1).hMenu, lUN, tP.x, tP.y, m_hWndOwner, tPM)
' Find the index of the item with id lR within the menu:
If lR > 0 Then
lIndex = ItemForID(lR)
ShowPopupMenu = lIndex
End If
If Not bIsSubclass Then
If lR > 0 Then
If m_tMI(lIndex).bChevronBehaviour Then
If Not m_tMI(lIndex).bChevronAppearance Then
raiseClickEventSub lIndex
End If
ShowPopupMenu = chevronPress(lIndex)
Else
raiseClickEventSub lIndex
End If
End If
DestroySubClass
End If
removeWindowHandles
SendMessageLong m_hWndOwner, WM_EXITMENULOOP, 1, 0
' The WM_COMMAND message is sent after this sub exits.
End Function
Public Function ShowPopupMenuAtIndex( _
ByVal lLeft As Long, _
ByVal lTop As Long, _
Optional ByVal lExcludeLeft As Long = 0, _
Optional ByVal lExcludeTop As Long = 0, _
Optional ByVal lExcludeRight As Long = 0, _
Optional ByVal lExcludeBottom As Long = 0, _
Optional ByVal bTryToKeepLeft As Boolean = True, _
Optional ByVal lIndex As Long = 1 _
) As Long
Attribute ShowPopupMenuAtIndex.VB_Description = "Shows a child Popup menu
within the current menu. This function returns the selected menu item index
or 0 if nothing was selected."
Dim tP As POINTAPI
Dim tP2 As POINTAPI
Dim tPM As TPMPARAMS
Dim lR As Long
Dim i As Long
Dim lUN As Long
Dim bIsSubclass As Boolean
Dim hMenu As Long
If lIndex > 0 Then
If lIndex <= 0 Or lIndex > Count Then
Exit Function
End If
hMenu = m_tMI(lIndex).hMenu
Else
If Count = 0 Then
Exit Function
End If
hMenu = m_tMI(1).hMenu
End If
tP.x = lLeft \ Screen.TwipsPerPixelX
tP.y = lTop \ Screen.TwipsPerPixelY
ClientToScreen m_hWndOwner, tP
If Abs(lExcludeLeft - lExcludeRight) > 0 Or Abs(lExcludeTop -
lExcludeBottom) > 0 Then
tP2.x = lExcludeLeft \ Screen.TwipsPerPixelX
tP2.y = lExcludeTop \ Screen.TwipsPerPixelY
ClientToScreen m_hWndOwner, tP2
tPM.rcExclude.left = tP2.x
tPM.rcExclude.top = tP2.y
tP2.x = lExcludeRight \ Screen.TwipsPerPixelX
tP2.y = lExcludeBottom \ Screen.TwipsPerPixelY
ClientToScreen m_hWndOwner, tP2
tPM.rcExclude.right = tP2.x
tPM.rcExclude.bottom = tP2.y
End If
tPM.cbSize = Len(tPM)
lUN = TPM_RETURNCMD
If Not (bTryToKeepLeft) Then
lUN = lUN Or TPM_VERTICAL
End If
If (m_bNoAnimation) Then
lUN = lUN Or TPM_NOANIMATION
End If
SendMessageLong m_hWndOwner, WM_ENTERMENULOOP, 1, 0
bIsSubclass = (m_hWndAttached <> 0)
showInfrequentlyUsed m_bShowInfrequent
CreateSubClass m_hWndOwner
lR = TrackPopupMenuEx(hMenu, lUN, tP.x, tP.y, m_hWndOwner, tPM)
' Find the index of the item with id lR within the menu:
If lR > 0 Then
lIndex = ItemForID(lR)
ShowPopupMenuAtIndex = lIndex
End If
If Not bIsSubclass Then
If lR > 0 Then
If m_tMI(lIndex).bChevronBehaviour Then
If Not m_tMI(lIndex).bChevronAppearance Then
raiseClickEventSub lIndex
End If
ShowPopupMenuAtIndex = chevronPress(lIndex)
Else
raiseClickEventSub lIndex
End If
End If
DestroySubClass
End If
removeWindowHandles
SendMessageLong m_hWndOwner, WM_EXITMENULOOP, 1, 0
' The WM_COMMAND message is sent after this sub exits.
End Function
Public Function ShowPopupAbsolute( _
ByVal lLeftPixel As Long, _
ByVal lTopPixel As Long, _
Optional ByVal lIndex As Long = 0, _
Optional ByVal bTryToKeepLeft As Boolean = True _
) As Long
Attribute ShowPopupAbsolute.VB_Description = "Shows a popup menu at an absolute
position on the screen specified in pixels."
Dim tR As RECT
Dim lUN As Long
Dim hMenu As Long
Dim bIsSubclass As Boolean
Dim lR As Long
If lIndex > 0 Then
If lIndex <= 0 Or lIndex > Count Then
Exit Function
End If
hMenu = m_tMI(lIndex).hMenu
Else
If Count = 0 Then
Exit Function
End If
hMenu = m_tMI(1).hMenu
End If
lUN = TPM_RETURNCMD
If Not (bTryToKeepLeft) Then
lUN = lUN Or TPM_VERTICAL
End If
If (m_bNoAnimation) Then
lUN = lUN Or TPM_NOANIMATION
End If
SendMessageLong m_hWndOwner, WM_ENTERMENULOOP, 1, 0
showInfrequentlyUsed m_bShowInfrequent
bIsSubclass = (m_hWndAttached <> 0)
CreateSubClass m_hWndOwner
lR = TrackPopupMenu(hMenu, lUN, lLeftPixel, lTopPixel, 0, m_hWndOwner, tR)
' Find the index of the item with id lR within the menu:
lIndex = ItemForID(lR)
ShowPopupAbsolute = lIndex
If Not bIsSubclass Then
If lR > 0 Then
If m_tMI(lIndex).bChevronBehaviour Then
If Not m_tMI(lIndex).bChevronAppearance Then
raiseClickEventSub lIndex
End If
ShowPopupAbsolute = chevronPress(lIndex)
Else
raiseClickEventSub lIndex
End If
End If
DestroySubClass
End If
removeWindowHandles
SendMessageLong m_hWndOwner, WM_EXITMENULOOP, 1, 0
' The WM_COMMAND message is sent after this sub exits.
End Function
Private Sub pSetMenuFlag( _
ByVal lIndex As Long, _
ByVal lFlag As Long, _
ByVal lFlagNot As Long _
)
Dim tMII As MENUITEMINFO
Dim lFlags As Long
lFlags = plMenuFlags(lIndex)
lFlags = (lFlags Or MF_OWNERDRAW) And Not MF_STRING
tMII.fMask = MIIM_SUBMENU
tMII.cbSize = LenB(tMII)
GetMenuItemInfo m_tMI(lIndex).hMenu, m_tMI(lIndex).lActualID, False, tMII
If (tMII.hSubMenu <> 0) Then
lFlags = lFlags Or MF_POPUP
End If
lFlags = lFlags And Not MF_BYPOSITION Or MF_BYCOMMAND
lFlags = lFlags Or lFlag
lFlags = lFlags And Not lFlagNot
ModifyMenuByLong m_tMI(lIndex).hMenu, m_tMI(lIndex).lActualID, lFlags,
m_tMI(lIndex).lActualID, m_tMI(lIndex).lItemData
End Sub
Public Property Get hMenu(ByVal lIndex As Long) As Long
Attribute hMenu.VB_Description = "Returns the Windows API menu handle for the
menu in which a menu item is located. Do not call Windows API methods which
modify the menu on this handle - you may disrupt the operation of the control.
This value is only valid until the next call of Clear"
hMenu = m_tMI(lIndex).hMenu
End Property
Private Sub pErr(ByVal sMsg As String)
Debug.Print sMsg
End Sub
Private Sub pAddNewMenuItem( _
ByRef tMI As tMenuItem _
)
Dim tMII As MENUITEMINFO
Dim hMenu As Long
Dim lPIndex As Long
Dim lFlags As Long
Dim lR As Long
Dim hMenuNew As Long
Dim bOk As Boolean
Dim i As Long
' Find out where we're adding this item:
With tMI
If (.lParentId = 0) Then
' This is a new top level menu item:
If (m_iMenuCount = 1) Then
' Create a new menu
hMenu = CreatePopupMenu()
Else
' Use the existing menu:
hMenu = m_tMI(1).hMenu
End If
Else
' We are adding to an existing menu:
' First we need to determine if there is already a sub menu for the
parent item:
lPIndex = plGetIndexForId(tMI.lParentId)
If (lPIndex = 0) Then
' Debug.Print " *** Couldn't find parent... *** "
Else
' Determine if the parent menu has a sub-menu:
tMII.fMask = MIIM_SUBMENU
tMII.cbSize = LenB(tMII)
GetMenuItemInfo m_tMI(lPIndex).hMenu, m_tMI(lPIndex).lActualID,
False, tMII
hMenu = tMII.hSubMenu
If (hMenu = 0) Then
' We don't have a sub menu for this item so we're
' going to have to add one:
' Debug.Print "Adding new sub-menu:"
' Create the new menu item and store it's handle so we can
clear up
' again later:
hMenu = CreatePopupMenu()
If (hMenu = 0) Then
pErr " *** Failed to create sub menu *** "
Else
' Check if hMenu isn't an ID:
bOk = False
If Not (pbIDIsUnique(hMenu)) Then
For i = 1 To 100
hMenuNew = CreatePopupMenu()
If (pbIDIsUnique(hMenuNew)) Then
DestroyMenu hMenu
hMenu = hMenuNew
bOk = True
Exit For
Else
DestroyMenu hMenuNew
End If
Next i
If Not bOk Then
' .. out of menu handles ...
DestroyMenu hMenu
pErr "Out of Menu Handles"
Exit Sub
End If
End If
m_lSubMenuCount = m_lSubMenuCount + 1
ReDim Preserve m_hSubMenus(1 To m_lSubMenuCount) As Long
m_hSubMenus(m_lSubMenuCount) = hMenu
' Now set the parent item so it has a popup menu:
lFlags = plMenuFlags(lPIndex)
lFlags = (lFlags Or MF_OWNERDRAW) And Not MF_STRING
lFlags = lFlags Or MF_POPUP
lFlags = lFlags And Not MF_BYPOSITION Or MF_BYCOMMAND
lR = ModifyMenuByLong(m_tMI(lPIndex).hMenu,
m_tMI(lPIndex).lActualID, lFlags, hMenu,
m_tMI(lPIndex).lItemData)
ItemData(lPIndex) = m_tMI(lPIndex).lItemData
If (lR = 0) Then
pErr "Failed to modify menu to add the sub menu " &
WinAPIError(Err.LastDllError)
End If
' WHen you add a sub menu to an item, its id becomes the
sub menu handle:
m_tMI(lPIndex).lActualID = hMenu
tMI.lParentId = hMenu
End If
End If
End If
End If
If (hMenu <> 0) Then
lFlags = plMenuFlags(m_iMenuCount)
lFlags = (lFlags Or MF_OWNERDRAW) And Not MF_STRING Or MF_BYPOSITION
lR = AppendMenuBylong(hMenu, lFlags, tMI.lID, tMI.lItemData)
If (lR = 0) Then
pErr "Failed to add new Menu item"
End If
End If
' Store the hMenu for this item:
.hMenu = hMenu
End With
End Sub
Private Function plMenuFlags( _
ByVal lIndex As Long _
)
Dim lFlags As Long
With m_tMI(lIndex)
If (.bChecked) Then
lFlags = lFlags Or MF_CHECKED
Else
lFlags = lFlags Or MF_UNCHECKED
End If
If (.bEnabled) Then
lFlags = lFlags Or MF_ENABLED
Else
lFlags = lFlags Or MF_GRAYED
End If
If left$(Trim$(.sInputCaption), 1) = "-" Or (.bTitle And Not .bDragOff)
Or Not (isVisible(lIndex)) Then
' Debug.Print .sInputCaption
lFlags = lFlags Or MF_SEPARATOR
End If
If (m_tMI(lIndex).bMenuBarBreak) Then
lFlags = lFlags Or MF_MENUBARBREAK
End If
If (m_tMI(lIndex).bMenuBreak) Then
lFlags = lFlags Or MF_MENUBREAK
End If
End With
plMenuFlags = lFlags
End Function
Private Function psExtractAccelerator( _
ByVal sCaption As String _
)
Dim i As Long
For i = 1 To Len(sCaption)
If (Mid$(sCaption, i, 1) = "&") Then
If (i < Len(sCaption)) Then
psExtractAccelerator = UCase$(Mid$(sCaption, (i + 1), 1))
End If
Exit For
End If
Next i
End Function
Private Function plGetNewID() As Long
Dim lID As Long
If (m_lLastMaxId < m_iMenuCount) Then
m_lLastMaxId = m_iMenuCount
Else
m_lLastMaxId = m_lLastMaxId + 1
End If
lID = m_lLastMaxId
Do Until (pbIDIsUnique(lID))
lID = lID + 1
m_lLastMaxId = lID
Loop
plGetNewID = lID
End Function
Private Function pbIDIsUnique( _
ByVal lID As Long _
) As Boolean
Dim bFound As Boolean
Dim lMenu As Long
For lMenu = 1 To m_iMenuCount
If (m_tMI(lMenu).lActualID = lID) Or (m_tMI(lMenu).lID = lID) Then
bFound = True
Exit For
End If
Next lMenu
pbIDIsUnique = Not (bFound)
End Function
Property Let TickIconIndex( _
ByVal lTickIconIndex As Long _
)
Attribute TickIconIndex.VB_Description = "Gets/sets a zero based index of an
icon in the ImageList to use to override the default check marks in the menu.
Set to -1 for the default."
m_lTickIconIndex = lTickIconIndex
End Property
Property Get TickIconIndex() As Long
TickIconIndex = m_lTickIconIndex
End Property
Property Let OptionIconIndex( _
ByVal lOptionIconIndex As Long _
)
Attribute OptionIconIndex.VB_Description = "Gets/sets a zero based index of an
icon in the ImageList to use to override the default radio (option) check
marks in the menu. Set to -1 for the default."
m_lOptionIconIndex = lOptionIconIndex
End Property
Property Get OptionIconIndex() As Long
OptionIconIndex = m_lOptionIconIndex
End Property
Public Sub CreateSubClass(hWndA As Long)
Attribute CreateSubClass.VB_Description = "Enables menu subclassing, so that
the Click event will fire."
If m_hWndAttached = hWndA Then
Else
DestroySubClass
'Debug.Print "ATTACH:START", hWndA
AttachMessage Me, hWndA, WM_MENUSELECT
AttachMessage Me, hWndA, WM_MEASUREITEM
AttachMessage Me, hWndA, WM_DRAWITEM
AttachMessage Me, hWndA, WM_COMMAND
AttachMessage Me, hWndA, WM_MENUCHAR
AttachMessage Me, hWndA, WM_INITMENUPOPUP
AttachMessage Me, hWndA, WM_UNINITMENUPOPUP
AttachMessage Me, hWndA, WM_MENURBUTTONUP
AttachMessage Me, hWndA, WM_WININICHANGE
AttachMessage Me, hWndA, WM_DESTROY
'Debug.Print "ATTACH:END", hWndA
m_hWndAttached = hWndA
End If
End Sub
Public Sub DestroySubClass()
Attribute DestroySubClass.VB_Description = "Stops subclassing the menu."
If Not (m_hWndAttached = 0) Then
'Debug.Print "DESTROY:START", m_hWndAttached
DetachMessage Me, m_hWndAttached, WM_MENUSELECT
DetachMessage Me, m_hWndAttached, WM_MEASUREITEM
DetachMessage Me, m_hWndAttached, WM_DRAWITEM
DetachMessage Me, m_hWndAttached, WM_COMMAND
DetachMessage Me, m_hWndAttached, WM_MENUCHAR
DetachMessage Me, m_hWndAttached, WM_INITMENUPOPUP
DetachMessage Me, m_hWndAttached, WM_UNINITMENUPOPUP
DetachMessage Me, m_hWndAttached, WM_MENURBUTTONUP
DetachMessage Me, m_hWndAttached, WM_WININICHANGE
DetachMessage Me, m_hWndAttached, WM_DESTROY
'Debug.Print "DESTROY:END", m_hWndAttached
m_hWndAttached = 0
End If
End Sub
Friend Function plGetIndexForId( _
ByVal lItemId As Long _
) As Long
Dim l As Long
Dim lIndex As Long
'Debug.Print "Finding Index:"
'Debug.Print lItemId
lIndex = 0
For l = 1 To m_iMenuCount
'Debug.Print " Index at l = " & m_tMI(l).lId
If (m_tMI(l).lActualID = lItemId) Then
lIndex = l
Exit For
End If
Next l
plGetIndexForId = lIndex
End Function
Private Function RaiseClickEvent(lID As Long) As Boolean
' Return true from this if we have completely handled the
' click on our own:
Dim lIndex As Long
' Find the Index of this menu id within our own array:
lIndex = plGetIndexForId(lID)
' If we find it, then raise a click event for it:
If (lIndex > 0) Then
If m_tMI(lIndex).bChevronBehaviour Then
chevronPress lIndex
Else
' Send a click event with the index:
raiseClickEventSub lIndex
' If this was one of the VB menu entries we have
' subclassed, we want to return false. Then the
' click will filter through to the original Click
' event so your code should work as normal:
On Error Resume Next ' 15/04/03: SPM: we may be unloading
If Not (m_tMI(lIndex).bIsAVBMenu) Then
RaiseClickEvent = True
End If
End If
Else
' This is a problem. We've got a click on
' a menu id which doesn't seem to be any
' of the menu items of the form. It shouldn't
' happen, but return false anyway so we don't eat
' the message.
pErr "Failed to find index for click event"
RaiseClickEvent = False
End If
End Function
Private Sub raiseClickEventSub(ByVal lIndex As Long)
' Check if this isn't a special chevron item:
If m_tMI(lIndex).lItemData = VBALCHEVRONMENUCONST Then
If parseToolbarItem(lIndex) Then
Exit Sub
End If
End If
RaiseEvent Click(lIndex)
End Sub
Private Function parseToolbarItem(ByVal lIndex As Long) As Boolean
' try and parse the key:
If Len(m_tMI(lIndex).sKey) > 4 Then
Dim iPos As Long, iNextPos As Long
Dim iPiece As Long
Dim sBit() As String
Dim lR As Long
iPos = 1
Do
iPiece = iPiece + 1
ReDim Preserve sBit(1 To iPiece) As String
iNextPos = InStr(iPos, m_tMI(lIndex).sKey, ":")
If (iNextPos = 0) Then
sBit(iPiece) = Mid$(m_tMI(lIndex).sKey, iPos)
Else
sBit(iPiece) = Mid$(m_tMI(lIndex).sKey, iPos, iNextPos - iPos)
iPos = iNextPos + 1
End If
Loop While (iNextPos > 0)
Dim lhWnd As Long
Dim lPtr As Long
Dim iButton As Long
Dim i As Long
Dim lhWndNotify As Long
Dim sKey As String
If iPiece > 1 Then
If sBit(1) = "_VBALCC" Then
If IsNumeric(sBit(2)) Then
lhWnd = CLng(sBit(2))
If IsWindow(lhWnd) Then
lPtr = GetProp(lhWnd, "vbalTbar:ControlPtr")
If (Not (lPtr = 0)) Then
Dim o As Object
Set o = ObjectFromPtr(lPtr)
If Not (o Is Nothing) Then
Select Case sBit(3)
Case "CST"
' customise
iButton = &H10000
Case "RST"
' reset
iButton = &H20000
Case "AOR"
' do nothing
iButton = &H30000
Case "BTN"
' flip the visible state for the specifed button.
If IsNumeric(sBit(4)) Then
' Get the button id:
iButton = CLng(sBit(4))
' Set the check state:
Checked(lIndex) = Not (Checked(lIndex))
' Now we need also to set the visible state for
the menu item
' which corresponds, but only if it *should* be
shown in
' the customise menu item list at this time (i.e.
it
' isn't visible in the toolbar).
If (iPiece > 4) Then
sKey = ""
For i = 5 To iPiece
If (i > 5) Then
sKey = sKey & ":"
End If
sKey = sKey & sBit(i)
Next i
i = IndexForKey(sKey)
If (i > 0) Then
' FIX 14/04/03: EMULATE MS CUSTOMISE
VERSION,
' We just leave the list of items alone
until customisation
' is over
'Visible(i) = Checked(lIndex)
End If
End If
Else
Exit Function
End If
End Select
' Send details of what we did to the toolbar:
Dim tHdr As NMHDR
tHdr.hwndFrom = lhWnd
tHdr.code = VBALCHEVRONMENUCONST
tHdr.idfrom = iButton
lhWndNotify = GetProp(lhWnd, "vbalTBar:NotifyWindow")
If (lhWndNotify = 0) Then
lhWndNotify = m_hWndOwner
End If
lR = SendMessageAsAny(lhWndNotify, WM_NOTIFY, 0, tHdr)
If (iButton < &H10000) Then
If (i > 0) Then
' here we could adjust what's shown in the
' menu. But that isn't done in
' OfficeXP so it isn't done here.
End If
End If
parseToolbarItem = True
End If
End If
End If
End If
End If
End If
End If
End Function
Private Sub RaiseHighlightEvent(lID As Long)
Dim lIndex As Long
Dim sCaption As String
Dim bSeparator As Boolean
lIndex = plGetIndexForId(lID)
' Debug.Print lIndex
If (lIndex > 0) Then
sCaption = Trim$(m_tMI(lIndex).sCaption)
' Debug.Print sCaption
If Len(sCaption) >= 1 Then
If left$(sCaption, 1) = "-" Then
bSeparator = True
End If
End If
If m_tMI(lIndex).bChevronBehaviour Then
chevronHover lIndex, True
Else
chevronHover 0, False
RaiseEvent ItemHighlight(lIndex, m_tMI(lIndex).bEnabled, bSeparator)
End If
Else
pErr "Failed to find Index for Highlight Id:" & lID & "," & lIndex
End If
End Sub
Private Sub RaiseInitMenuEvent( _
ByVal hMenu As Long, _
ByVal bState As Boolean _
)
Dim lIndex As Long
Dim lParentId As Long
Dim bFound As Boolean
' not hovering over a chevron
chevronHover 0, False
' Firstly, we need to find the index of an item
' in hMenu:
For lIndex = m_iMenuCount To 1 Step -1
If (m_tMI(lIndex).hMenu = hMenu) Then
lParentId = m_tMI(lIndex).lParentId
bFound = True
End If
If (bFound) Then
If (m_tMI(lIndex).lActualID = lParentId) Then
If bState Then
RaiseEvent InitPopupMenu(lIndex)
Else
RaiseEvent UnInitPopupMenu(lIndex)
End If
Exit For
End If
End If
Next lIndex
End Sub
Private Sub RaiseMenuExitEvent()
' not over a chevron:
chevronHover 0, False
' raise the event:
RaiseEvent MenuExit
End Sub
Private Sub chevronHover(ByVal lIndex As Long, ByVal bState As Boolean)
'
If bState Then
If Not (lIndex = m_lChevronIndex) Then ' check for already hovering
timeBeginPeriod 10
m_lChevronStartTime = timeGetTime()
m_lHoverIndex = lIndex
m_lChevronIndex = lIndex
evaluateMenuWindows
If m_tMI(lIndex).bChevronAppearance Then
m_tmrChevron.Interval = 500
Else
m_tmrChevron.Interval = -1
End If
End If
Else
If m_lChevronIndex <> 0 Or (m_lHoverIndex <> lIndex) Then
m_lHoverIndex = lIndex
End If
m_lChevronIndex = 0
m_tmrChevron.Interval = -1
timeEndPeriod 10
End If
'
End Sub
Private Function pGetTextPosition( _
ByVal lHDC As Long, _
ByVal lIndex As Long, _
ByRef rcItem As RECT _
)
Dim tC As RECT
Dim lDiff As Long
Dim lMenuHeight As Long
lMenuHeight = m_lMenuItemHeight
' Determine the size of the text to draw:
DrawText lHDC, m_tMI(lIndex).sCaption, Len(m_tMI(lIndex).sCaption), tC,
DT_CALCRECT
' We want to centre the text vertically:
lDiff = lMenuHeight - (tC.bottom - tC.top)
If (lDiff > 0) Then
rcItem.top = rcItem.top + lDiff \ 2
End If
' All normal menu items are indented by to
' accomodate icon & checked surround for icon:
rcItem.left = rcItem.left + lMenuHeight + 2
End Function
Private Function DrawItem(ByVal wParam As Long, ByVal lparam As Long) As Long
Attribute DrawItem.VB_Description = "Raised whenever a menu item with the
OwnerDraw style needs to be drawn."
Dim tDIS As DRAWITEMSTRUCT
Dim hBr As Long, hPen As Long, hPenOld As Long
Dim tR As RECT, tTR As RECT, tWR As RECT
Dim tJunk As POINTAPI
Dim lHDC As Long
Dim hFntOld As Long, hFntSymOld As Long, hFontInt As Long
Dim tMII As MENUITEMINFO
Dim bRadioCheck As Boolean, bChecked As Boolean
Dim bDisabled As Boolean, bHighlighted As Boolean
Dim bHeader As Boolean, bSeparator As Boolean
Dim bDefault As Boolean
Dim bInfrequent As Boolean, bChevron As Boolean
Dim bPriorInfrequent As Boolean, bNextInfrequent As Boolean
Dim bDoDefault As Boolean
Dim lID As Long
Dim lSelLeft As Long
Dim sCC As String
Dim lIconIndex As Long
Dim lX As Long, lY As Long
Dim hBrush As Long
Dim lIndex As Long
Dim bCanHighlight As Boolean
CopyMemory tDIS, ByVal lparam, Len(tDIS)
'Debug.Print "Drawing item", tDIS.itemID
If tDIS.CtlType = ODT_MENU Then
lIndex = (plGetIndexForId(tDIS.itemID))
If (lIndex > 0) Then
If Not isVisible(lIndex) Then
DrawItem = True
Exit Function
End If
' ensure the memory dc is big enough:
m_cMemDC.Width = tDIS.rcItem.right - tDIS.rcItem.left + 2
m_cMemDC.Height = tDIS.rcItem.bottom - tDIS.rcItem.top + 2
lHDC = m_cMemDC.hdc
LSet tR = tDIS.rcItem
OffsetRect tR, -tR.left, -tR.top
' Get info about the menu item:
tMII.cbSize = LenB(tMII)
tMII.fMask = MIIM_TYPE Or MIIM_STATE 'Or MIIM_DATA
ReDim b(0 To 128) As Byte
tMII.dwTypeData = VarPtr(b(0))
GetMenuItemInfo tDIS.hwndItem, tDIS.itemID, False, tMII
bRadioCheck = m_tMI(lIndex).bRadioCheck '((tMII.fType And
MFT_RADIOCHECK) = MFT_RADIOCHECK)
bDisabled = Not (m_tMI(lIndex).bEnabled) '((tMII.fState And
MFS_DISABLED) = MFS_DISABLED)
bChecked = ((tMII.fState And MFS_CHECKED) = MFS_CHECKED) Or bRadioCheck
bHighlighted = ((tMII.fState And MFS_HILITE) = MFS_HILITE)
bHeader = m_tMI(lIndex).bTitle
bSeparator = isSeparator(lIndex)
bDefault = m_tMI(lIndex).bDefault
bInfrequent = m_tMI(lIndex).bInfrequent
bChevron = m_tMI(lIndex).bChevronAppearance
'Debug.Print lIndex, m_tMI(lIndex).sCaption, bInfrequent, bSeparator
' Fill background:
tR.bottom = tR.bottom + 1
tR.right = tR.right + 1
LSet tTR = tR
If bInfrequent Then
getNextAndPriorInfrequentStates lIndex, bPriorInfrequent,
bNextInfrequent
LSet tWR = tTR
If (m_OfficeXPStyle) Then
fillWithLighterControlColour lHDC, tWR, tDIS.rcItem.top
Else
fillWithLighterBackColor lHDC, tWR, tDIS.rcItem.top, True
End If
If Not bPriorInfrequent Then
If Not (bHighlighted) Then
tWR.bottom = tWR.top + 1
fillWithNormalBackground lHDC, tWR, tDIS.rcItem.top
LSet tWR = tTR
If Not (m_OfficeXPStyle) Then
hPen = CreatePen(PS_SOLID, 1,
TranslateColor(vbButtonShadow))
hPenOld = SelectObject(lHDC, hPen)
MoveToEx lHDC, tWR.left, tWR.top + 1, tJunk
LineTo lHDC, tWR.right, tWR.top + 1
SelectObject lHDC, hPenOld
DeleteObject hPen
End If
End If
End If
If Not bNextInfrequent Then
hPen = CreatePen(PS_SOLID, 1, TranslateColor(vb3DHighlight))
hPenOld = SelectObject(lHDC, hPen)
MoveToEx lHDC, tWR.left, tWR.bottom - 2, tJunk
LineTo lHDC, tWR.right, tWR.bottom - 2
SelectObject lHDC, hPenOld
DeleteObject hPen
End If
Else
fillWithNormalBackground lHDC, tTR, tDIS.rcItem.top
End If
If (m_OfficeXPStyle) Then
Dim tSideRect As RECT
LSet tSideRect = tTR
tSideRect.right = m_lMenuItemHeight + 8
fillWithLighterControlColour lHDC, tSideRect, tDIS.rcItem.top
End If
tR.top = tR.top + 1
SetBkMode lHDC, TRANSPARENT
' set the appropriate font:
If bDefault Then
hFntOld = SelectObject(lHDC, hFontBold)
Else
hFntOld = SelectObject(lHDC, hFont)
End If
bDoDefault = True
If (m_tMI(lIndex).bOwnerDraw) Then
' this is unfortunate
LSet tTR = tDIS.rcItem
Dim lW As Long, lH As Long
lW = tTR.right - tTR.left + 1
lH = tTR.bottom - tTR.top + 1
tTR.top = tTR.top - 1
tTR.bottom = tTR.bottom + 1
BitBlt tDIS.hdc, tDIS.rcItem.left, tDIS.rcItem.top, lW, lH, lHDC,
0, 0, vbSrcCopy
RaiseEvent DrawItem(tDIS.hdc, lIndex, tTR.left, tTR.top, tTR.right,
tTR.bottom, bHighlighted, bChecked, bDisabled, bDoDefault)
BitBlt lHDC, 0, 0, lW, lH, tDIS.hdc, tDIS.rcItem.left,
tDIS.rcItem.top, vbSrcCopy
tR.left = tTR.left - tDIS.rcItem.left
tR.top = tTR.top - tDIS.rcItem.top + 1
End If
' ensure we have the window handle for the menu:
addWindowHandle tDIS.hdc, m_tMI(lIndex).hMenu
If (bDoDefault) Then
If bSeparator Or (bHeader And Not (HeaderStyle =
ecnmHeaderCaptionBar)) Then
' Separator:
LSet tWR = tR
tWR.top = (tWR.bottom - tWR.top - 2) \ 2 + tWR.top
tWR.bottom = tWR.top + 2
InflateRect tWR, -12, 0
If m_bImageProcessBitmap And Not (m_cBitmapLight Is Nothing) Then
tWR.bottom = tWR.top
fillWithHighlightBackColor lHDC, tWR, tDIS.rcItem.top +
tWR.top
tWR.top = tWR.top + 1
tWR.bottom = tWR.top
fillWithLighterBackColor lHDC, tWR, tDIS.rcItem.top +
tWR.top, False
Else
If (m_OfficeXPStyle) Then
Dim tWRS As RECT
LSet tWRS = tWR
tWRS.left = tSideRect.right + 4
tWRS.right = tWRS.right + 20
tWRS.top = tWRS.top + 1
tWRS.bottom = tWRS.top
DrawEdge lHDC, tWRS, BDR_SUNKENOUTER, BF_TOP Or BF_BOTTOM,
True
Else
DrawEdge lHDC, tWR, BDR_SUNKENOUTER, BF_TOP Or BF_BOTTOM,
False
End If
End If
End If
If bChevron Then
'
LSet tWR = tR
tWR.top = tWR.bottom - 15
tWR.right = tWR.right - 2
tWR.bottom = tWR.bottom - 1
If bHighlighted Then
If (m_OfficeXPStyle) Then
fillWithLighterSelectedColour lHDC, tWR, tDIS.rcItem.top +
tWR.top
Else
fillWithLighterControlColour lHDC, tWR, tDIS.rcItem.top +
tWR.top
End If
LSet tTR = tWR
DrawEdge lHDC, tTR, BDR_RAISEDINNER, BF_RECT, m_OfficeXPStyle
End If
' draw the chevron:
hPen = CreatePen(PS_SOLID, 1,
TranslateColor(InActiveMenuForeColor))
hPenOld = SelectObject(lHDC, hPen)
LSet tTR = tWR
tTR.left = ((tTR.right - tTR.left) \ 2) - 3 + tTR.left
tTR.top = tTR.top + 2
MoveToEx lHDC, tTR.left, tTR.top, tJunk
LineTo lHDC, tTR.left + 3, tTR.top + 3
MoveToEx lHDC, tTR.left, tTR.top + 1, tJunk
LineTo lHDC, tTR.left + 3, tTR.top + 3 + 1
MoveToEx lHDC, tTR.left, tTR.top + 4, tJunk
LineTo lHDC, tTR.left + 3, tTR.top + 3 + 4
MoveToEx lHDC, tTR.left, tTR.top + 1 + 4, tJunk
LineTo lHDC, tTR.left + 3, tTR.top + 3 + 1 + 4
MoveToEx lHDC, tTR.left + 4, tTR.top, tJunk
LineTo lHDC, tTR.left + 4 - 3, tTR.top + 3
MoveToEx lHDC, tTR.left + 4, tTR.top + 1, tJunk
LineTo lHDC, tTR.left + 4 - 3, tTR.top + 3 + 1
MoveToEx lHDC, tTR.left + 4, tTR.top + 4, tJunk
LineTo lHDC, tTR.left + 4 - 3, tTR.top + 3 + 4
MoveToEx lHDC, tTR.left + 4, tTR.top + 1 + 4, tJunk
LineTo lHDC, tTR.left + 4 - 3, tTR.top + 3 + 1 + 4
SelectObject lHDC, hPenOld
DeleteObject hPen
'
End If
If (Not (bSeparator Or bChevron)) Or bHeader Then
' Text item:
lID = tMII.dwItemData
' Icon?
lIconIndex = m_tMI(lIndex).lIconIndex
If bChecked Or lIconIndex > -1 Then
lSelLeft = tR.left + 4 + (tR.bottom - tR.top + 1 - 4)
If m_tMI(lIndex).bShowCheckAndIcon Then
lSelLeft = lSelLeft + m_lMenuItemHeight + 8
End If
End If
If bHighlighted And Not (bHeader Or bDisabled) Then
If m_bGradientHighlight Then
' Draw a gradient:
LSet tWR = tR
tWR.left = tR.left + lSelLeft + 1
tWR.right = tWR.left + 4 + (tR.bottom - tR.top + 1 - 4)
hBr =
CreateSolidBrush(TranslateColor(ActiveMenuBackgroundColor)
)
FillRect lHDC, tWR, hBr
DeleteObject hBr
LSet tWR = tR
tWR.left = tWR.left + 4 + (tR.bottom - tR.top + 1 - 4)
DrawGradient lHDC, tWR,
TranslateColor(ActiveMenuBackgroundColor),
TranslateColor(MenuBackgroundColor), False
ElseIf m_bButtonHighlightStyle Then
' do nothing now
Else
' standard:
If (m_OfficeXPStyle) Then
LSet tWR = tR
tWR.left = tWR.left + 1
tWR.right = tWR.right - 2
fillWithLighterSelectedColour lHDC, tWR,
tDIS.rcItem.top + tWR.top
DrawEdge lHDC, tWR, 0, 0, True
Else
LSet tWR = tR
tWR.left = lSelLeft + 1
fillWithHighlightBackColor lHDC, tWR, tDIS.rcItem.top +
tWR.top
End If
End If
End If
If m_bButtonHighlightStyle And bChecked And Not (bHighlighted)
And Not (bDisabled) Then
LSet tWR = tR
fillWithLighterBackColor lHDC, tWR, tDIS.rcItem.top +
tWR.top, False
End If
If bDisabled Then
SetTextColor lHDC, TranslateColor(vb3DHighlight)
Else
If bHighlighted Then
SetTextColor lHDC, TranslateColor(ActiveMenuForeColor)
Else
SetTextColor lHDC, TranslateColor(InActiveMenuForeColor)
End If
End If
LSet tWR = tR
If (bHeader) Then
' no icons/checks
Else
' Get the check/icon space:
If m_bButtonHighlightStyle Then
InflateRect tWR, -2, 0
tWR.bottom = tWR.bottom - 1
Else
tWR.left = tWR.left + 1
End If
tWR.right = tWR.left + (tWR.bottom - tWR.top + 1 - 2)
' Check:
If bChecked Then
' Colour in:
If Not (bHighlighted) And Not (bDisabled) Then
If Not m_bButtonHighlightStyle Then
tWR.top = tWR.top + 1
If (m_OfficeXPStyle) Then
fillWithLighterControlColour lHDC, tWR,
tDIS.rcItem.top + tWR.top
Else
fillWithLighterBackColor lHDC, tWR,
tDIS.rcItem.top + tWR.top, False
End If
tWR.top = tWR.top - 1
End If
If bDisabled Then
SetTextColor lHDC, TranslateColor(vb3DHighlight)
End If
End If
If Not bDisabled Then
If bHighlighted And Not (m_OfficeXPStyle) Then
SetTextColor lHDC,
TranslateColor(ActiveMenuForeColor)
Else
SetTextColor lHDC,
TranslateColor(InActiveMenuForeColor)
End If
End If
tWR.right = tWR.right + 1
If Not m_bButtonHighlightStyle Then
If (m_OfficeXPStyle) Then
tWR.top = tWR.top + 1
tWR.bottom = tWR.bottom - 1
DrawEdge lHDC, tWR, BDR_SUNKENOUTER, BF_RECT,
m_OfficeXPStyle
tWR.top = tWR.top - 1
tWR.bottom = tWR.bottom + 1
Else
tWR.bottom = tWR.bottom - 1
DrawEdge lHDC, tWR, BDR_SUNKENOUTER, BF_RECT,
m_OfficeXPStyle
tWR.bottom = tWR.bottom + 1
End If
End If
If lIconIndex = -1 Or m_tMI(lIndex).bShowCheckAndIcon Then
' Draw the appropriate symbol:
hFontInt = SelectObject(lHDC, hFntOld)
hFntSymOld = SelectObject(lHDC, hFontSymbol)
If bHighlighted And Not (m_OfficeXPStyle) Then
SetTextColor lHDC,
TranslateColor(InActiveMenuForeColor)
End If
If bRadioCheck Then
pDrawText lHDC, "h", tWR, DT_VCENTER Or DT_CENTER Or
DT_SINGLELINE, bDisabled
Else
pDrawText lHDC, "b", tWR, DT_VCENTER Or DT_CENTER Or
DT_SINGLELINE, bDisabled
End If
SelectObject lHDC, hFntSymOld
If bDefault Then
hFntOld = SelectObject(lHDC, hFontBold)
Else
hFntOld = SelectObject(lHDC, hFont)
End If
If bHighlighted And Not (m_OfficeXPStyle) Then
SetTextColor lHDC,
TranslateColor(ActiveMenuForeColor)
Else
SetTextColor lHDC,
TranslateColor(InActiveMenuForeColor)
End If
End If
If lIconIndex > -1 Then
If m_tMI(lIndex).bShowCheckAndIcon Then
OffsetRect tWR, m_lMenuItemHeight + 8, 0
End If
lX = tWR.left + (tWR.right - tWR.left + 1 -
m_lIconSize) \ 2
lY = tWR.top + (tWR.bottom - tWR.top + 1 - m_lIconSize)
\ 2
If bDisabled Then
ImageListDrawIconDisabled m_ptrVb6ImageList, lHDC,
m_hIml, lIconIndex, lX, lY, m_lIconSize
Else
If (bHighlighted And m_OfficeXPStyle) Then
ImageListDrawIconDisabled m_ptrVb6ImageList,
lHDC, m_hIml, lIconIndex, lX + 1, lY + 1,
m_lIconSize, True
ImageListDrawIcon m_ptrVb6ImageList, lHDC,
m_hIml, lIconIndex, lX - 1, lY - 1
Else
ImageListDrawIcon m_ptrVb6ImageList, lHDC,
m_hIml, lIconIndex, lX, lY
End If
End If
If m_tMI(lIndex).bShowCheckAndIcon Then
OffsetRect tWR, -(m_lMenuItemHeight + 8), 0
End If
End If
Else
If lIconIndex > -1 Then
If m_tMI(lIndex).bShowCheckAndIcon Then
If bHighlighted And Not (bHeader Or bDisabled) Then
If Not m_bButtonHighlightStyle Then
LSet tTR = tWR
tTR.right = m_lMenuItemHeight + 8
If Not (m_OfficeXPStyle) Then
' draw the highlight where the check is:
fillWithHighlightBackColor lHDC, tTR,
tDIS.rcItem.top + tTR.top
End If
End If
End If
' move:
OffsetRect tWR, m_lMenuItemHeight + 8, 0
End If
If bHighlighted And Not (bDisabled Or m_OfficeXPStyle)
Then
If Not (m_bButtonHighlightStyle) Then
tWR.right = tWR.right + 1
DrawEdge lHDC, tWR, BDR_RAISEDINNER, BF_RECT,
m_OfficeXPStyle
tWR.right = tWR.right - 1
End If
End If
lX = tWR.left + (tWR.right - tWR.left + 1 -
m_lIconSize) \ 2
lY = tWR.top + (tWR.bottom - tWR.top + 1 - m_lIconSize)
\ 2
lX = lX + 2 * Abs(m_bButtonHighlightStyle)
If bDisabled Then
ImageListDrawIconDisabled m_ptrVb6ImageList, lHDC,
m_hIml, lIconIndex, lX, lY, m_lIconSize
Else
If (bHighlighted And m_OfficeXPStyle) Then
ImageListDrawIconDisabled m_ptrVb6ImageList,
lHDC, m_hIml, lIconIndex, lX + 1, lY + 1,
m_lIconSize, True
ImageListDrawIcon m_ptrVb6ImageList, lHDC,
m_hIml, lIconIndex, lX - 1, lY - 1
Else
ImageListDrawIcon m_ptrVb6ImageList, lHDC,
m_hIml, lIconIndex, lX, lY
End If
End If
If m_tMI(lIndex).bShowCheckAndIcon Then
OffsetRect tWR, -(m_lMenuItemHeight + 8), 0
End If
End If
End If
End If
' Draw text:
If bHeader Then
hFontInt = SelectObject(lHDC, hFntOld)
hFntSymOld = SelectObject(lHDC,
m_cNCM.FontHandle(SMCaptionFont))
tWR.left = tWR.left + 1
tWR.top = tWR.top + 1
If HeaderStyle = ecnmHeaderCaptionBar Then
' caption bar:
If bHighlighted And m_tMI(lIndex).bDragOff Then
hBrush =
CreateSolidBrush(TranslateColor(vbActiveTitleBar))
SetTextColor lHDC, TranslateColor(vbTitleBarText)
dragOffHighlighted lIndex
Else
hBrush =
CreateSolidBrush(TranslateColor(vbInactiveTitleBar))
SetTextColor lHDC, TranslateColor(vbInactiveCaptionText)
End If
FillRect lHDC, tWR, hBrush
DeleteObject hBrush
DrawText lHDC, m_tMI(lIndex).sCaption, -1, tWR, DT_CENTER
Or DT_SINGLELINE Or DT_VCENTER
Else
' separator:
DrawText lHDC, m_tMI(lIndex).sCaption, -1, tTR, DT_LEFT Or
DT_SINGLELINE Or DT_CALCRECT
InflateRect tTR, 2, 0
tR.left = tWR.left + ((tWR.right - tWR.left) - (tTR.right
- tTR.left)) \ 2
tR.right = tR.left + (tTR.right - tTR.left)
tR.top = tWR.top + ((tWR.bottom - tWR.top) - (tTR.bottom -
tTR.top)) \ 2
tR.bottom = tR.top + (tTR.bottom - tTR.top)
If m_cBitmap Is Nothing Then
hBr =
CreateSolidBrush(TranslateColor(MenuBackgroundColor))
FillRect lHDC, tR, hBr
DeleteObject hBr
Else
TileArea lHDC, tR.left, tR.top, tR.right - tR.left + 1,
tR.bottom - tR.top + 1, m_cBitmap.hdc,
m_cBitmap.Width, m_cBitmap.Height, tDIS.rcItem.top
End If
SetTextColor lHDC, TranslateColor(InActiveMenuForeColor)
tR.left = tR.left + 2
DrawText lHDC, m_tMI(lIndex).sCaption, -1, tR, DT_LEFT Or
DT_SINGLELINE
End If
SelectObject lHDC, hFntSymOld
hFntOld = SelectObject(lHDC, hFontInt)
Else
' Not header
If m_bButtonHighlightStyle And Not (bDisabled) Or
(m_OfficeXPStyle) Then
SetTextColor lHDC, TranslateColor(InActiveMenuForeColor)
End If
LSet tWR = tR
tWR.left = tR.left + 4 + (tR.bottom - tR.top + 1 - 4) + 2 + 1
If m_tMI(lIndex).bShowCheckAndIcon Then
tWR.left = tWR.left + (tR.bottom - tR.top + 1)
End If
If (m_OfficeXPStyle) Then
tWR.left = tWR.left + 4
End If
pDrawText lHDC, m_tMI(lIndex).sCaption, tWR, DT_LEFT Or
DT_SINGLELINE Or DT_VCENTER, bDisabled
If Len(m_tMI(lIndex).sShortCutDisplay) > 0 Then
tWR.left = tWR.left + m_tMI(lIndex).lShortCutStartPos + 4
+ 4
pDrawText lHDC, m_tMI(lIndex).sShortCutDisplay, tWR,
DT_LEFT Or DT_SINGLELINE Or DT_VCENTER, bDisabled
End If
' Highlighted:
If m_bButtonHighlightStyle And Not (bDisabled) Then
LSet tWR = tR
InflateRect tWR, 0, 1
tWR.right = tWR.right - 2
tWR.bottom = tWR.bottom - 1
If bHighlighted Then
DrawEdge lHDC, tWR, BDR_RAISEDINNER, BF_RECT,
m_OfficeXPStyle
ElseIf bChecked Then
tWR.top = tWR.top + 1
DrawEdge lHDC, tWR, BDR_SUNKENOUTER, BF_RECT,
m_OfficeXPStyle
End If
End If
End If
End If
SelectObject lHDC, hFntOld
If Not hFntOld = 0 Then
SelectObject lHDC, hFntOld
End If
DrawItem = True
End If
BitBlt tDIS.hdc, tDIS.rcItem.left, tDIS.rcItem.top, tDIS.rcItem.right
- tDIS.rcItem.left + 1, tDIS.rcItem.bottom - tDIS.rcItem.top + 1,
lHDC, 0, 0, vbSrcCopy
Else
'Debug.Print "Failed to find item to draw.", tDI.itemID, lIndex
End If
Else
DrawItem = CallOldWindowProc(m_hWndOwner, WM_DRAWITEM, wParam, lparam)
End If
End Function
Private Sub getNextAndPriorInfrequentStates(ByVal lIndex As Long, ByRef
bPriorInfrequent As Boolean, ByRef bNextInfrequent As Boolean)
Dim lCount As Long
Dim lPrior As Long
Dim lNext As Long
Dim lPosition As Long
' need to find out our position on this menu, then derive
' the prior & subsequent menu position
' very inefficient..
lCount = GetMenuItemCount(m_tMI(lIndex).hMenu)
lPosition = plMenuPositionForIndex(m_tMI(lIndex).hMenu, lIndex)
lPrior = plFindItemInMenu(m_tMI(lIndex).hMenu, lPosition - 1)
lNext = plFindItemInMenu(m_tMI(lIndex).hMenu, lPosition + 1)
If lPrior > 0 Then
bPriorInfrequent = (m_tMI(lPrior).bInfrequent)
End If
If lNext > 0 Then
bNextInfrequent = (m_tMI(lNext).bInfrequent)
End If
End Sub
Private Sub fillWithLighterBackColor(ByVal lHDC As Long, tR As RECT, ByVal
lOffsetY As Long, ByVal bInfrequent As Boolean)
Dim hBrush As Long
SetBkMode lHDC, OPAQUE
If Not m_cBitmapLight Is Nothing Then
TileArea lHDC, tR.left, tR.top, tR.right - tR.left + 1, tR.bottom -
tR.top + 1, m_cBitmapLight.hdc, m_cBitmapLight.Width,
m_cBitmapLight.Height, lOffsetY
Else
If (NoPalette) Then
If bInfrequent Then
hBrush =
CreateSolidBrush(SlightlyLighterColour(MenuBackgroundColor))
Else
hBrush = CreateSolidBrush(LighterColour(MenuBackgroundColor))
End If
FillRect lHDC, tR, hBrush
DeleteObject hBrush
Else
m_cBrush.Rectangle lHDC, tR.left, tR.top, tR.right - tR.left + 1,
tR.bottom - tR.top + 1, 1, PATCOPY, True, MenuBackgroundColor,
vb3DHighlight
End If
End If
SetBkMode lHDC, TRANSPARENT
End Sub
Private Sub fillWithHighlightBackColor(ByVal lHDC As Long, tR As RECT, ByVal
lOffsetY As Long)
Dim hBr As Long
If m_cBitmapDark Is Nothing Then
hBr = CreateSolidBrush(TranslateColor(ActiveMenuBackgroundColor))
FillRect lHDC, tR, hBr
DeleteObject hBr
Else
TileArea lHDC, tR.left, tR.top, tR.right - tR.left + 1, tR.bottom -
tR.top + 1, m_cBitmapDark.hdc, m_cBitmapDark.Width,
m_cBitmapDark.Height, lOffsetY
End If
End Sub
Private Sub fillWithNormalBackground(ByVal lHDC As Long, tR As RECT, ByVal
lOffsetY As Long)
Dim hBrush As Long
If m_cBitmap Is Nothing Then
hBrush = CreateSolidBrush(TranslateColor(MenuBackgroundColor))
FillRect lHDC, tR, hBrush
DeleteObject hBrush
Else
TileArea lHDC, tR.left, tR.top, tR.right - tR.left + 1, tR.bottom -
tR.top + 1, m_cBitmap.hdc, m_cBitmap.Width, m_cBitmap.Height, lOffsetY
End If
End Sub
Private Sub fillWithLighterControlColour(ByVal lHDC As Long, tR As RECT, ByVal
lOffsetY As Long)
Dim hBrush As Long
SetBkMode lHDC, OPAQUE
If Not m_cBitmapLight Is Nothing Then
TileArea lHDC, tR.left, tR.top, tR.right - tR.left + 1, tR.bottom -
tR.top + 1, m_cBitmapLight.hdc, m_cBitmapLight.Width,
m_cBitmapLight.Height, lOffsetY
Else
If (NoPalette) Then
hBrush = CreateSolidBrush(BlendColor(vbButtonFace,
MenuBackgroundColor))
FillRect lHDC, tR, hBrush
DeleteObject hBrush
Else
m_cBrush.Rectangle lHDC, tR.left, tR.top, tR.right - tR.left + 1,
tR.bottom - tR.top + 1, 1, PATCOPY, True, MenuBackgroundColor,
vb3DHighlight
End If
End If
SetBkMode lHDC, TRANSPARENT
End Sub
Private Sub fillWithLighterSelectedColour(ByVal lHDC As Long, tR As RECT, ByVal
lOffsetY As Long)
Dim hBrush As Long
SetBkMode lHDC, OPAQUE
If Not m_cBitmapLight Is Nothing Then
TileArea lHDC, tR.left, tR.top, tR.right - tR.left + 1, tR.bottom -
tR.top + 1, m_cBitmapLight.hdc, m_cBitmapLight.Width,
m_cBitmapLight.Height, lOffsetY
Else
If (NoPalette) Then
hBrush = CreateSolidBrush(BlendColor(vbHighlight, MenuBackgroundColor))
FillRect lHDC, tR, hBrush
DeleteObject hBrush
Else
m