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: fTest.frm
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmMenuTest
Caption = "vbAccelerator Popup Menu Component"
ClientHeight = 5205
ClientLeft = 2850
ClientTop = 2580
ClientWidth = 6600
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "fTest.frx":0000
LinkTopic = "Form1"
ScaleHeight = 5205
ScaleWidth = 6600
Begin VB.CommandButton cmdCustomise
Caption = "Cus&tomise"
Height = 375
Left = 1320
TabIndex = 19
ToolTipText = "Click to show a demonstration menu with sub levels."
Top = 660
Width = 1215
End
Begin VB.PictureBox picFrame
BackColor = &H80000005&
Height = 3135
Left = 60
ScaleHeight = 3075
ScaleWidth = 5295
TabIndex = 8
Top = 1080
Width = 5355
Begin VB.PictureBox picOptions
BackColor = &H80000005&
BorderStyle = 0 'None
Height = 1935
Left = 0
ScaleHeight = 1935
ScaleWidth = 5235
TabIndex = 10
Top = 0
Width = 5235
Begin VB.CheckBox chkVisual
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "&Office XP Style"
ForeColor = &H80000008&
Height = 315
Index = 5
Left = 2700
TabIndex = 20
Top = 1560
Value = 1 'Checked
Width = 2415
End
Begin VB.CheckBox chkVisual
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "&Show Infrequently Used"
ForeColor = &H80000008&
Height = 315
Index = 4
Left = 2700
TabIndex = 18
Top = 1260
Value = 1 'Checked
Width = 2415
End
Begin VB.CheckBox chkVisual
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "Image &Process Bitmap for Highlights"
Enabled = 0 'False
ForeColor = &H80000008&
Height = 375
Index = 3
Left = 2940
TabIndex = 17
Top = 600
Value = 1 'Checked
Width = 1995
End
Begin VB.CheckBox chkVisual
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "&Title Style Separators"
ForeColor = &H80000008&
Height = 315
Index = 2
Left = 2700
TabIndex = 16
Top = 960
Width = 2415
End
Begin VB.OptionButton optSelectionStyle
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "&Standard Highlight"
ForeColor = &H80000008&
Height = 255
Index = 0
Left = 60
TabIndex = 15
Top = 60
Value = -1 'True
Width = 2055
End
Begin VB.OptionButton optSelectionStyle
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "&Gradient Highlight"
ForeColor = &H80000008&
Height = 255
Index = 1
Left = 60
TabIndex = 14
Top = 300
Width = 2055
End
Begin VB.OptionButton optSelectionStyle
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "&Button Highlight"
ForeColor = &H80000008&
Height = 255
Index = 2
Left = 60
TabIndex = 13
Top = 540
Width = 2055
End
Begin VB.CheckBox chkVisual
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "&Custom Colours/Font"
ForeColor = &H80000008&
Height = 315
Index = 0
Left = 2700
TabIndex = 12
Top = 0
Width = 2415
End
Begin VB.CheckBox chkVisual
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "Bac&kground Bitmap"
ForeColor = &H80000008&
Height = 315
Index = 1
Left = 2700
TabIndex = 11
Top = 300
Width = 2415
End
End
Begin VB.ListBox lstStatus
Appearance = 0 'Flat
Height = 1515
IntegralHeight = 0 'False
Left = 0
TabIndex = 9
ToolTipText = "Right click to get an Edit popup menu"
Top = 1560
Width = 5355
End
End
Begin VB.CommandButton cmdTest2
Caption = "&Test"
Height = 375
Left = 3960
TabIndex = 7
Top = 8820
Width = 1155
End
Begin VB.CommandButton cmdTest
Caption = "&Test"
Height = 375
Left = 3960
TabIndex = 5
Top = 8400
Width = 1155
End
Begin VB.CommandButton cmdAccelTest
Caption = "&Accelerator"
Height = 375
Left = 5220
TabIndex = 4
Top = 660
Width = 1095
End
Begin VB.CommandButton cmdCheck
Caption = "&Checks"
Height = 375
Left = 3960
TabIndex = 3
Top = 660
Width = 1155
End
Begin VB.CommandButton cmdVBAccel
Height = 375
Left = 2580
Picture = "fTest.frx":030A
Style = 1 'Graphical
TabIndex = 1
ToolTipText = "Connect to vbAccelerator - the VB Programmer's
Resource"
Top = 660
Width = 1275
End
Begin VB.CommandButton cmdNewMenu
Caption = "&Show Menu"
Height = 375
Left = 60
TabIndex = 0
ToolTipText = "Click to show a demonstration menu with sub levels."
Top = 660
Width = 1215
End
Begin VB.PictureBox picBackground
AutoSize = -1 'True
BorderStyle = 0 'None
Height = 1920
Left = 1800
Picture = "fTest.frx":08D1
ScaleHeight = 1920
ScaleWidth = 1920
TabIndex = 6
Top = 3240
Visible = 0 'False
Width = 1920
End
Begin MSComctlLib.ImageList ilsIcons16
Left = 120
Top = 4500
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 43
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":C913
Key = "PASTE"
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":CC2D
Key = "CUT"
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":CF47
Key = "COPY"
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":D261
Key = ""
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":D57B
Key = ""
EndProperty
BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":D895
Key = ""
EndProperty
BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":DBAF
Key = ""
EndProperty
BeginProperty ListImage8 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":DEC9
Key = ""
EndProperty
BeginProperty ListImage9 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":E1E3
Key = ""
EndProperty
BeginProperty ListImage10 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":E4FD
Key = ""
EndProperty
BeginProperty ListImage11 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":E817
Key = ""
EndProperty
BeginProperty ListImage12 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":EB31
Key = ""
EndProperty
BeginProperty ListImage13 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":EE4B
Key = ""
EndProperty
BeginProperty ListImage14 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":F165
Key = ""
EndProperty
BeginProperty ListImage15 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":F47F
Key = ""
EndProperty
BeginProperty ListImage16 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":F799
Key = ""
EndProperty
BeginProperty ListImage17 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":FAB3
Key = ""
EndProperty
BeginProperty ListImage18 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":FDCD
Key = ""
EndProperty
BeginProperty ListImage19 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":100E7
Key = ""
EndProperty
BeginProperty ListImage20 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":10401
Key = ""
EndProperty
BeginProperty ListImage21 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":1071B
Key = ""
EndProperty
BeginProperty ListImage22 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":10A35
Key = ""
EndProperty
BeginProperty ListImage23 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":10D4F
Key = ""
EndProperty
BeginProperty ListImage24 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":11069
Key = ""
EndProperty
BeginProperty ListImage25 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":11383
Key = ""
EndProperty
BeginProperty ListImage26 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":1169D
Key = ""
EndProperty
BeginProperty ListImage27 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":119B7
Key = ""
EndProperty
BeginProperty ListImage28 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":11CD1
Key = ""
EndProperty
BeginProperty ListImage29 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":11FEB
Key = ""
EndProperty
BeginProperty ListImage30 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":12305
Key = ""
EndProperty
BeginProperty ListImage31 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":1261F
Key = ""
EndProperty
BeginProperty ListImage32 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":12939
Key = ""
EndProperty
BeginProperty ListImage33 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":12C53
Key = ""
EndProperty
BeginProperty ListImage34 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":12F6D
Key = ""
EndProperty
BeginProperty ListImage35 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":13287
Key = ""
EndProperty
BeginProperty ListImage36 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":135A1
Key = ""
EndProperty
BeginProperty ListImage37 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":138BB
Key = ""
EndProperty
BeginProperty ListImage38 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":13BD5
Key = ""
EndProperty
BeginProperty ListImage39 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":13EEF
Key = "Web"
EndProperty
BeginProperty ListImage40 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":14209
Key = ""
EndProperty
BeginProperty ListImage41 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":14523
Key = ""
EndProperty
BeginProperty ListImage42 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":1483D
Key = ""
EndProperty
BeginProperty ListImage43 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "fTest.frx":14B57
Key = "vbAccelerator"
EndProperty
EndProperty
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = "Click one of the buttons below or Right Click in the
list box to demonstrate unlimited Popup-menus with icons."
Height = 555
Left = 60
TabIndex = 2
Top = 60
Width = 6495
End
Begin VB.Menu mnuF0MAIN
Caption = "&File"
Begin VB.Menu mnuFile
Caption = "&New..."
Index = 0
Shortcut = ^N
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 1
End
Begin VB.Menu mnuFile
Caption = "&Open"
Index = 2
End
Begin VB.Menu mnuFile
Caption = "&Save"
Index = 3
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 4
End
Begin VB.Menu mnuFile
Caption = "&Close"
Index = 5
End
End
Begin VB.Menu mnuEditTOP
Caption = "&Edit"
Index = 0
Begin VB.Menu mnuEdit
Caption = "&Change Caption"
Index = 0
End
Begin VB.Menu mnuEdit
Caption = "-"
Index = 1
End
Begin VB.Menu mnuEdit
Caption = "&Show Hidden Items"
Index = 2
End
End
Begin VB.Menu mnuHelpTOP
Caption = "&Help"
Begin VB.Menu mnuHelp
Caption = "&vbAccelerator on the Web"
Index = 0
Shortcut = {F1}
End
Begin VB.Menu mnuHelp
Caption = "Add vbAccelerator Active &Channel..."
Index = 1
End
Begin VB.Menu mnuHelp
Caption = "-"
Index = 2
End
Begin VB.Menu mnuHelp
Caption = "&About.."
Index = 3
End
End
End
Attribute VB_Name = "frmMenuTest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'
===============================================================================
=======
'
' Name: vbAccelerator VB6 PopupMenu Component Demonstrator
' Author: Steve McMahon (steve@vbaccelerator.com)
' Date: 18 February 2001
'
' Requires: cNewMenu6.DLL
' SSUBTMR6.DLL
'
' Copyright 1998-2001 Steve McMahon for vbAccelerator
'
'
-------------------------------------------------------------------------------
-------
' Visit vbAccelerator - advanced free source code for VB programmers
' http://vbaccelerator.com
'
-------------------------------------------------------------7-----------------
-------
Private WithEvents cP As cPopupMenu
Attribute cP.VB_VarHelpID = -1
Private Const mcWEBSITE = -&H8000&
Private Sub Status(ByVal sMsg As String)
lstStatus.AddItem sMsg
lstStatus.ListIndex = lstStatus.NewIndex
End Sub
Private Sub chkVisual_Click(Index As Integer)
' custom colours
If chkVisual(0).Value = vbChecked Then
' colours if background bitmap on
If chkVisual(1).Value = vbChecked Then
cP.MenuBackgroundColor = &H99CCCC
cP.InActiveMenuForeColor = &H333333
cP.ActiveMenuBackgroundColor = &H336666
cP.ActiveMenuForeColor = &HFFFFFF
' colours if background bitmap off
Else
cP.MenuBackgroundColor = &H333333
cP.InActiveMenuForeColor = &H999999
cP.ActiveMenuBackgroundColor = &H3380EE
cP.ActiveMenuForeColor = &HFFFFFF
End If
Dim sFnt As New StdFont
sFnt.Name = "Verdana"
sFnt.Size = 10
cP.Font = sFnt
' non custom colours
Else
cP.MenuBackgroundColor = -1
cP.InActiveMenuForeColor = -1
cP.ActiveMenuForeColor = -1
cP.ActiveMenuBackgroundColor = -1
cP.Font = Nothing
End If
' background picture
If chkVisual(1).Value = vbChecked Then
chkVisual(3).Enabled = True
cP.ImageProcessHighlights = (chkVisual(3).Value = vbChecked)
cP.BackgroundPicture = picBackground.Picture
Else
chkVisual(3).Enabled = False
cP.BackgroundPicture = Nothing
End If
' separator with text style
If chkVisual(2).Value = vbChecked Then
cP.HeaderStyle = ecnmHeaderCaptionBar
Else
cP.HeaderStyle = ecnmHeaderSeparator
End If
' infrequently used
cP.HideInfrequentlyUsed = (chkVisual(4).Value = vbUnchecked)
cP.OfficeXpStyle = (chkVisual(5).Value = vbChecked)
End Sub
Private Sub cmdAccelTest_Click()
Dim iIndex As Long
' Whilst the accelerator menu is the active menu, you can use Alt+Home,
' Alt+Right Arrow and Alt+Left Arrow accelerators.
With cP
.Restore "AccelTest"
iIndex = .IndexForKey("mnuAccel(3)")
iIndex = .ShowPopupMenu( _
cmdAccelTest.Left, cmdAccelTest.Top + cmdAccelTest.Height, _
cmdAccelTest.Left, cmdAccelTest.Top, cmdAccelTest.Left +
cmdAccelTest.Width, cmdAccelTest.Top + cmdAccelTest.Height _
)
.Store "AccelTest"
End With
End Sub
Private Sub cmdCheck_Click()
Dim iIndex As Long
With cP
.Restore "CheckTest"
iIndex = .ShowPopupMenu( _
cmdCheck.Left, cmdCheck.Top + cmdCheck.Height, _
cmdCheck.Left, cmdCheck.Top, cmdCheck.Left + cmdCheck.Width,
cmdCheck.Top + cmdCheck.Height _
)
If iIndex > 0 Then
If InStr(.ItemKey(iIndex), "Option") <> 0 Then
.GroupToggle iIndex
ElseIf InStr(.ItemKey(iIndex), "Check") <> 0 Then
.Checked(iIndex) = Not (.Checked(iIndex))
End If
.Store "CheckTest"
End If
End With
End Sub
Private Sub cmdCustomise_Click()
Dim iIndex As Long
With cP
If Not .CurrentlyRestoredKey = "Customise" Then
.Restore "Customise"
End If
iIndex = .ShowPopupMenu( _
cmdCustomise.Left, cmdCustomise.Top + cmdCustomise.Height, _
cmdCustomise.Left, cmdCustomise.Top, cmdCustomise.Left +
cmdCustomise.Width, cmdCustomise.Top + cmdCustomise.Height _
)
If (iIndex > 0) Then
Status "ShowPopupMenu Returned: Selected Item=" & iIndex & ";Caption="
& cP.Caption(iIndex)
.Store "Customise"
End If
End With
End Sub
Private Sub cmdNewMenu_Click()
Dim iIndex As Long
With cP
If Not .CurrentlyRestoredKey = "Demo" Then
.Restore "Demo"
End If
.Caption(1) = "Test Modify Caption"
.Caption(6) = "Test Modify Caption 2"
.Default(6) = True
iIndex = .ShowPopupMenu( _
cmdNewMenu.Left, cmdNewMenu.Top + cmdNewMenu.Height, _
cmdNewMenu.Left, cmdNewMenu.Top, cmdNewMenu.Left + cmdNewMenu.Width,
cmdNewMenu.Top + cmdNewMenu.Height _
)
If (iIndex > 0) Then
Status "ShowPopupMenu Returned: Selected Item=" & iIndex & ";Caption="
& cP.Caption(iIndex)
If (.ItemKey(iIndex) = "CHECK") Then
.Checked(iIndex) = Not (.Checked(iIndex))
.Store "Demo"
End If
End If
End With
End Sub
Private Sub cmdTest_Click()
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
With cP
.Clear
For i = 1 To 10
i = .AddItem("Test" & i, , , , , , , "Test" & i)
Next i
For i = 1 To 10
k = .InsertItem("InsTest" & i, "Test3", , , , , , "Test" & j)
If i = 3 Then
For j = 1 To 10
.AddItem "SubTest" & j, , , k, , , , "SubTest" & j
Next j
End If
Next i
k = .InsertItem("InsTOP", "Test1", , , , , , "InsTOP")
k = .AddItem("InsTopSub 1", , , k, , , , "InsTopSub1")
For j = 1 To 4
.InsertItem "InsTopSub " & j + 1, "InsTopSub1", , , , , , "InsTopSub"
& j + 1
Next j
k = .InsertItem("InsBOTTOM", "Test10", , , , , , "InsBOTTOM")
For j = 1 To 5
.AddItem "InsBottom" & j, , , k, , , , "InsBottom" & j
Next j
.ShowPopupMenu 0, 0
.ClearSubMenusOfItem "InsTOP"
k = .IndexForKey("InsTOP")
For j = 1 To 24
.AddItem "InsTopSub " & j, , , k, , , , "InsTopSub" & j
Next j
.ClearSubMenusOfItem "InsBOTTOM"
k = .IndexForKey("InsTopSub20")
For j = 1 To 24
i = .AddItem("InsTopSubSub " & j, , , k, , , , "InsTopSubSub" & j)
If j Mod 5 = 0 Then
For n = 1 To Rnd * 8 + 4
.AddItem "Testing" & n, , , i
Next n
End If
Next j
.ShowPopupMenu 0, 0
End With
End Sub
Private Sub cmdTest2_Click()
With cP
.RestoreFromFile , "C:\Stevemac\VB\Controls\vbalTbar\Menu.dat"
.Restore "Main"
.ShowPopupMenu 0, 0
End With
End Sub
Private Sub cmdVBAccel_Click()
Dim iIndex As Long
With cP
.Restore "vbAccelerator"
iIndex = .ShowPopupMenu( _
cmdVBAccel.Left, cmdVBAccel.Top + cmdVBAccel.Height, _
cmdVBAccel.Left, cmdVBAccel.Top, cmdVBAccel.Left + cmdVBAccel.Width,
cmdVBAccel.Top + cmdVBAccel.Height _
)
If (iIndex > 0) Then
Status "ShowPopupMenu Returned: Selected Item=" & iIndex & ";Caption="
& cP.Caption(iIndex)
If (.ItemKey(iIndex) = "Web") Then
mnuHelp_Click 0
ElseIf (.ItemKey(iIndex) = "Channel") Then
mnuHelp_Click 1
ElseIf (.ItemData(iIndex) = mcWEBSITE) Then
Screen.MousePointer = vbHourglass
ShellEx .ItemKey(iIndex)
Screen.MousePointer = vbDefault
End If
End If
End With
End Sub
Private Sub cP_Click(ItemNumber As Long)
Status "Clicked Item=" & ItemNumber & ";Caption=" & cP.Caption(ItemNumber)
If cP.ItemKey(ItemNumber) = "CHECK" Then
cP.Checked(ItemNumber) = Not (cP.Checked(ItemNumber))
End If
End Sub
Private Sub cP_InitPopupMenu(ParentItemNumber As Long)
Status "InitPopupMenu with Parent= " & ParentItemNumber
End Sub
Private Sub cP_ItemHighlight(ItemNumber As Long, bEnabled As Boolean,
bSeparator As Boolean)
Status "Highlighted Item=" & ItemNumber & ",Caption=" &
cP.Caption(ItemNumber) & ", Enabled=" & bEnabled & ", Separator = " &
bSeparator
End Sub
Private Sub cP_MenuExit()
Status "Menu Exited."
End Sub
Private Sub cP_UnInitPopupMenu(ParentItemNumber As Long)
Status "UnInitPopupMenu with Parent= " & ParentItemNumber
End Sub
Private Sub Form_Load()
Set cP = New cPopupMenu
' Make sure you set this up before trying any menus
cP.hWndOwner = Me.hWnd
' Make sure the ImageList has icons before setting
' this if it is a MS ImageList:
cP.ImageList = ilsIcons16
cP.HeaderStyle = ecnmHeaderSeparator
' Create some menus and store them:
createMenus
chkVisual(2).Value = Checked
chkVisual(5).Value = Checked
End Sub
Private Sub createMenus()
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim iIndex As Long
Dim lIcon As Long
Dim sKey As String
Dim sCap As String
' Create the demo menu:
With cP
.Clear
For i = 1 To 10
If (i = 6) Or (i = 7) Then sKey = "CHECK" Else sKey = ""
iIndex = .AddItem("Test " & i, , i, , i + 3, ((i = 6) Or (i = 7)), ((i
Mod 3) <> 0), sKey)
If (i = 5) Then
' Add some submenus:
For j = 1 To 30
sCap = "SubMenu Test" & j
If ((j - 1) Mod 10) = 0 And j > 1 Then
' start a new column:
sCap = "|" & sCap
End If
k = .AddItem(sCap, , , iIndex, j + 10)
Next j
ElseIf (i = 8) Or (i = 9) Then
' Make items invisible:
.Visible(iIndex) = False
.ItemKey(iIndex) = "INVISIBLE" & i - 7
End If
If (i = 4) Or (i = 5) Then
' separators:
.AddItem "-"
End If
Next i
' Save this menu:
.Store "Demo"
' create a customise menu
.Clear
For i = 1 To 5
k = .AddItem("Test Item " & i, , , , i - 1)
Next i
.AddItem "-"
j = .AddItem("&Add or Remove Buttons")
For i = 1 To 20
k = .AddItem("Test Item " & i, , , j, i - 1, (i <= 5), , "CHECK")
.ShowCheckAndIcon(k) = True
.RedisplayMenuOnClick(k) = True
Next i
k = .AddItem("-", , , j)
k = .AddItem("&Reset Toolbar...", , , j)
k = .AddItem("&Customise...", , , j)
.Store "Customise"
' Create the edit menu:
.Clear
.AddItem "Cu&t" & vbTab & "Ctrl+X", , , ,
ilsIcons16.ListImages("CUT").Index - 1, , , "Cut"
.AddItem "&Copy" & vbTab & "Ctrl+C", , , ,
ilsIcons16.ListImages("COPY").Index - 1, , , "Copy"
.AddItem "&Paste" & vbTab & "Ctrl+V", , , ,
ilsIcons16.ListImages("PASTE").Index - 1, , False, "Paste"
.Store "Edit"
' Create the vbAccelerator menu:
.Clear
.AddItem "-vbAccelerator"
lIcon = ilsIcons16.ListImages("vbAccelerator").Index - 1
.AddItem "&vbAccelerator on the Web..." & vbTab & "F1", , , , lIcon, , ,
"Web"
.Default(2) = True
lIcon = ilsIcons16.ListImages("Web").Index - 1
.AddItem "Add vbAccelerator Active &Channel...", , mcWEBSITE, , lIcon, ,
, "Channel"
.AddItem "-Other sites"
i = .AddItem("VB Sites", , , , lIcon)
.AddItem "-VB Sites", , , i
.AddItem "VBWire", , mcWEBSITE, i, lIcon, , , "http://vbwire.com/"
.AddItem "VBNet", , mcWEBSITE, i, lIcon, , , "http://www.mvps.org/mvps"
.AddItem "CCRP", , mcWEBSITE, i, lIcon, , , "http://www.mvps.org/ccrp"
.AddItem "DevX", , mcWEBSITE, i, lIcon, , , "http://www.devx.com/"
i = .AddItem("Technology", , , , lIcon)
.AddItem "-Games", , , i
.AddItem "Dave's Classics", , mcWEBSITE, i, lIcon, , ,
"http://www.davesclassics.com/"
.AddItem "Future Gamer", , mcWEBSITE, i, lIcon, , ,
"http://www.futuregamer.com/"
.AddItem "-Web Site Building", , , i
.AddItem "Builder.com", , mcWEBSITE, i, lIcon, , ,
"http://www.builder.com/"
.AddItem "The Web Design Resource", , mcWEBSITE, i, lIcon, , ,
"http://www.pageresource.com/"
.AddItem "Web Review", , mcWEBSITE, i, lIcon, , ,
"http://www.webreview.com/"
.AddItem "-Downloads", , , i
.AddItem "CNet", , mcWEBSITE, i, lIcon, , , "http://www.cnet.com/"
.AddItem "WinFiles.com", , mcWEBSITE, i, lIcon, , ,
"http://www.winfiles.com/"
i = .AddItem("Searching and Other", , , , lIcon)
j = .AddItem("Pick'n'Mix", , , i)
.Header(j) = True
.AddItem "The SCHWA Corporation", , mcWEBSITE, i, lIcon, , ,
"http://www.theschwacorporation.com/"
.AddItem "Art Cars", , mcWEBSITE, i, lIcon, , , "http://www.artcars.com/"
.AddItem "The Onion", , mcWEBSITE, i, lIcon, , ,
"http://www.theonion.com/"
.AddItem "Virtues of a Programmer", i, mcWEBSITE, i, lIcon, , ,
"http://www.hhhh.org/wiml/virtues.html"
.AddItem "-Search", , , i
.AddItem "Google", , mcWEBSITE, i, lIcon, , , "http://www.google.com/"
.AddItem "DogPile", , mcWEBSITE, i, lIcon, , , "http://www.dogpile.com/"
.Store "vbAccelerator"
.Clear
.AddItem "First Check", , , , , True, , "Check1"
.AddItem "Second Check", , , , , , , "Check2"
.AddItem "Third Check", , , , , , , "Check3"
.AddItem "-"
i = .AddItem("First Option", , , , , , , "Option1")
.RadioCheck(i) = True
'Debug.Print .RadioCheck(i)
.AddItem "Second Option", , , , , , , "Option2"
.AddItem "Third Option", , , , , , , "Option3"
.AddItem "Fourth Option", , , , , , , "Option4"
.AddItem "-"
.AddItem "&vbAccelerator on the Web...", , , , lIcon, , , "Web"
.Store "CheckTest"
.Clear
.AddItem "&Back" & vbTab & "Alt+Left Arrow", , , , , , , "mnuAccel(0)"
.AddItem "&Next" & vbTab & "Alt+Right Arrow", , , , , , , "mnuAccel(1)"
.AddItem "-"
j = .AddItem("&Home Page" & vbTab & "Alt+Home", , , , , , , "mnuAccel(3)")
.ItemInfrequentlyUsed(j) = True
j = .AddItem("&Search the Web", , , , , , , "mnuAccel(4)")
.ItemInfrequentlyUsed(j) = True
.AddItem "-"
j = .AddItem("&Mail", , , , , , , "mnuAccel(6)")
.ItemInfrequentlyUsed(j) = True
j = .AddItem("&News", , , , , , , "mnuAccel(7)")
.ItemInfrequentlyUsed(j) = True
.AddItem "My &Computer", , , , , , , "mnuAccel(8)"
.ItemInfrequentlyUsed(j) = True
j = .AddItem("A&ddress Book", , , , , , , "mnuAccel(9)")
.ItemInfrequentlyUsed(j) = True
j = .AddItem("Ca&lendar", , , , , , , "mnuAccel(10)")
.ItemInfrequentlyUsed(j) = True
j = .AddItem("&Internet Call", , , , , , , "mnuAccel(11)")
.ItemInfrequentlyUsed(j) = True
i = .AddItem("Other &Links", , , , , , , "mnuAccel(12)")
lIcon = ilsIcons16.ListImages("Web").Index - 1
j = .AddItem("Planet-Mu Records", "http://www.planet-mu.com/", , i,
lIcon, , , "mnuLink(0)")
j = .AddItem("Speedranch/Jansky Noise", "http://www.forcefield.org/", ,
i, lIcon, , , "mnuLink(1)")
j = .AddItem("LFO Discography",
"http://www.sci.fi/~phinnweb/links/artists/lfo/", , i, lIcon, , ,
"mnuLink(2)")
j = .AddItem("All Tommorrow's Parties",
"http://www.alltomorrowsparties.co.uk/", , i, lIcon, , , "mnuLink(3)")
j = .AddItem("XLR8R Magazine", "http://www.xlr8r.com/", , i, lIcon, , ,
"mnuLink(4)")
j = .AddItem("Superbad", "http://www.superbad.com/", , i, lIcon, , ,
"mnuLink(5)")
.ItemInfrequentlyUsed(j) = True
j = .AddItem("Stereolab", "http://www.stereolab.co.uk/", , i, lIcon, , ,
"mnuLink(6)")
.ItemInfrequentlyUsed(j) = True
j = .AddItem("Pixies Discography",
"http://www.evo.org/html/group/pixies.html", , i, lIcon, , ,
"mnuLink(7)")
.ItemInfrequentlyUsed(j) = True
j = .AddItem("IconMenu Links", , , i, lIcon, , , "mnuLink(8)")
For l = 1 To 10
k = .AddItem("Test Menu " & l, , , j, lIcon)
.ItemInfrequentlyUsed(k) = (l <> 2)
Next l
.Store "AccelTest"
End With
End Sub
Private Sub Form_Resize()
On Error Resume Next
picFrame.Move picFrame.Left, picFrame.Top, Me.ScaleWidth - picFrame.Left *
2, Me.ScaleHeight - picFrame.Top - 4 * Screen.TwipsPerPixelY
End Sub
Private Sub lstStatus_MouseDown(Button As Integer, Shift As Integer, x As
Single, y As Single)
If (Button And vbRightButton) = vbRightButton Then
Dim iIndex As Long
cP.Restore "Edit"
cP.Enabled(cP.IndexForKey("Paste")) = Clipboard.GetFormat(vbCFText)
iIndex = cP.ShowPopupMenu( _
x + lstStatus.Left, y + lstStatus.Top + picFrame.Top)
If (iIndex > 0) Then
Status "Clicked " & iIndex
End If
End If
End Sub
Private Sub mnuEdit_Click(Index As Integer)
Select Case Index
Case 0
cP.Caption(2) = "Changed to this - longer than it was before, I guess."
Case 2
If Not cP.CurrentlyRestoredKey = "Demo" Then
cP.Restore "Demo"
End If
cP.Visible(cP.IndexForKey("INVISIBLE1")) = Not
(cP.Visible(cP.IndexForKey("INVISIBLE1")))
cP.Visible(cP.IndexForKey("INVISIBLE2")) = Not
(cP.Visible(cP.IndexForKey("INVISIBLE2")))
cP.Store "Demo"
mnuEdit(Index).Checked = Not (mnuEdit(Index).Checked)
End Select
End Sub
Private Sub mnuFile_Click(Index As Integer)
Dim sFile As String
Select Case Index
Case 0
' New window
Dim f As New frmMenuTest
f.Show
Dim x As Single, y As Single
x = f.Left + 120 * Screen.TwipsPerPixelX
y = f.Top + 120 * Screen.TwipsPerPixelY
If x + f.Width > Screen.Width Then x = 0
If y + f.Height > Screen.Height Then y = 0
f.Move x, y
Case 2
' Demonstrates Deserialising menu:
sFile = App.Path & "\Test.Dat"
cP.RestoreFromFile , sFile
Case 3
' Demonstrates Serialising menu:
sFile = App.Path & "\Test.Dat"
cP.StoreToFile , sFile
Case 5
Unload Me
End Select
End Sub
Private Sub mnuHelp_Click(Index As Integer)
Select Case Index
Case 0
' vbAccelerator!
Screen.MousePointer = vbHourglass
ShellEx "http://vbaccelerator.com", , , , , Me.hWnd
Screen.MousePointer = vbDefault
Case 1
' Add vbAccelerator Active Channel
Screen.MousePointer = vbHourglass
ShellEx "http://vbaccelerator.com/vbaccel.cdf", , , , , Me.hWnd
Screen.MousePointer = vbDefault
Case 3
' About
frmAbout.Show vbModal, Me
End Select
End Sub
Private Sub optSelectionStyle_Click(Index As Integer)
Select Case True
Case optSelectionStyle(0)
cP.GradientHighlight = False
cP.ButtonHighlight = False
Case optSelectionStyle(1)
cP.GradientHighlight = True
cP.ButtonHighlight = False
Case optSelectionStyle(2)
cP.GradientHighlight = False
cP.ButtonHighlight = True
End Select
End Sub
Private Sub picFrame_Resize()
On Error Resume Next
picOptions.Width = picFrame.ScaleWidth
lstStatus.Move -2 * Screen.TwipsPerPixelX, picOptions.Top +
picOptions.Height - 2 * Screen.TwipsPerPixelY, picFrame.ScaleWidth + 4 *
Screen.TwipsPerPixelX, picFrame.ScaleHeight - (picOptions.Top +
picOptions.Height) + 4 * Screen.TwipsPerPixelY
End Sub
