VB5 Icon Menu DLL Demonstration (61K)
VB5 Icon Menu DLL Full Source (106K)
VB5 IconMenu DLL Binary (20K)
VB6 IconMenu DLL Binary (21K)
VB6 IconMenu DLL Demonstration (58K)
VB6 IconMenu DLL Full Source (101K)
28 Mar 2003
Added Office XP Menu style
Added VB6 ImageList Compatibility for XP, and fixed bug with disabling of icons for MS Image Lists.
Tidied sample code up.
PopupMenu DLL - Create Unlimited Popup Menus
vbAccelerator NeoCaption Component v2.0
Subclassing Without The Crashes
vbAccelerator ImageList Control and Class v2.0
vbAccelerator - Contents of code file: fMenuTst.frm
VERSION 5.00
Object = "{8245A918-4CF7-11D2-8E21-10B404C10000}#8.1#0"; "vbalIml.ocx"
Begin VB.Form frmTest
Caption = "vbAccelerator IconMenu DLL Demonstration"
ClientHeight = 6195
ClientLeft = 5745
ClientTop = 4410
ClientWidth = 5580
BeginProperty Font
Name = "Verdana"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Icon = "fMenuTst.frx":0000
LinkTopic = "Form1"
ScaleHeight = 6195
ScaleWidth = 5580
Begin VB.PictureBox picStatus
Align = 2 'Align Bottom
BorderStyle = 0 'None
Height = 825
Left = 0
ScaleHeight = 825
ScaleWidth = 5580
TabIndex = 23
Top = 5370
Width = 5580
Begin VB.PictureBox picVBAccel
AutoSize = -1 'True
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 390
Left = 60
Picture = "fMenuTst.frx":030A
ScaleHeight = 330
ScaleWidth = 1275
TabIndex = 24
ToolTipText = "Free, Advanced source code for VB Programmers at
http://vbaccelerator.com"
Top = 0
Width = 1335
End
Begin VB.Label lblStatus
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 60
TabIndex = 26
Top = 420
Width = 8235
End
Begin VB.Label lblVBAccel
Caption = "Visit vbAccelerator - free, advanced source code
for VB Programmers - at http://vbaccelerator.com"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 405
Left = 1440
TabIndex = 25
Top = 0
Width = 3915
End
End
Begin vbalIml.vbalImageList ilsIcons
Left = 360
Top = 4920
_ExtentX = 953
_ExtentY = 953
ColourDepth = 4
Size = 22960
Images = "fMenuTst.frx":0863
Version = 131072
KeyCount = 20
Keys =
"SPELLCHKPRINTNEWDATEDELETEFIND_DOCFIND_ARRDOWNLOADFAVEFONTUNDOREDOBINOCH
ELPWEB_LINKSAVEPASTEOPENCUTCOPY"
End
Begin VB.Frame fraSpecialEffects
Caption = "Special Effects/Styles"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2115
Left = 2760
TabIndex = 15
Top = 2640
Width = 2595
Begin VB.CheckBox chkOfficeXPStyle
Caption = "&Office XP Style"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 22
Top = 1620
Value = 1 'Checked
Width = 2295
End
Begin VB.CheckBox chkCustomColours
Caption = "&Customised Colours/Font"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 21
Top = 1380
Width = 2295
End
Begin VB.CheckBox chkBackground
Caption = "&Background Bitmap"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 20
Top = 1140
Width = 2295
End
Begin VB.OptionButton optButtonSelect
Caption = "Button &Select Style"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 2
Left = 120
TabIndex = 19
Top = 780
Width = 2415
End
Begin VB.OptionButton optButtonSelect
Caption = "&Gradient Select Style"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 1
Left = 120
TabIndex = 18
Top = 540
Width = 2415
End
Begin VB.OptionButton optButtonSelect
Caption = "Stan&dard Select"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 0
Left = 120
TabIndex = 17
Top = 300
Value = -1 'True
Width = 2415
End
End
Begin VB.Frame fraMore
Caption = "More Demonstration Forms:"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1275
Left = 2760
TabIndex = 12
Top = 1260
Width = 2595
Begin VB.CommandButton cmdMDIDemo
Caption = "&MDI Demo..."
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 555
Left = 180
TabIndex = 13
Top = 300
Width = 1155
End
End
Begin VB.Frame fraPopup
Caption = "&Show Popup Menus"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1215
Left = 2760
TabIndex = 10
Top = 0
Width = 2595
Begin VB.CommandButton cmdVBPopup
Caption = "VB Popup:"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 120
TabIndex = 11
Top = 360
Width = 1155
End
End
Begin VB.Frame fraAddRemove
Caption = "Change Visibility"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2115
Left = 60
TabIndex = 9
Top = 2640
Width = 2595
Begin VB.CommandButton cmdVisible
Caption = "Make File Item Visible..."
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 555
Left = 300
TabIndex = 16
Top = 300
Width = 1155
End
End
Begin VB.Frame fraManipulate
Caption = "Manipulate Menu Items"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2595
Left = 60
TabIndex = 1
Top = 0
Width = 2595
Begin VB.PictureBox picIcon
AutoRedraw = -1 'True
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 555
Left = 1560
ScaleHeight = 495
ScaleWidth = 555
TabIndex = 8
Top = 1800
Width = 615
End
Begin VB.CommandButton cmdChangeIcon
Caption = "Change &Paste Icon"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 555
Left = 300
TabIndex = 6
Top = 1800
Width = 1155
End
Begin VB.CommandButton cmdChangeCaption
Caption = "Change &Paste Caption"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 555
Left = 300
TabIndex = 5
Top = 1140
Width = 1155
End
Begin VB.CheckBox chkEnable
Caption = "Paste Enabled"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 60
TabIndex = 4
Top = 240
Width = 1395
End
Begin VB.CheckBox chkNewest
Caption = "Check &Newest"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 60
TabIndex = 3
Top = 480
Width = 1515
End
Begin VB.CheckBox chkENewest
Caption = "Enable Newest"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 60
TabIndex = 2
Top = 780
Value = 1 'Checked
Width = 1515
End
Begin VB.Label lblCaption
Caption = "&Paste"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 1560
TabIndex = 7
Top = 1200
Width = 915
End
End
Begin VB.CommandButton cmdUnload
Caption = "&Close"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 435
Left = 4200
TabIndex = 0
Top = 4860
Width = 1155
End
Begin VB.PictureBox picBackground
AutoSize = -1 'True
BorderStyle = 0 'None
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1920
Left = 2940
Picture = "fMenuTst.frx":6233
ScaleHeight = 1920
ScaleWidth = 1920
TabIndex = 14
Top = 3780
Visible = 0 'False
Width = 1920
End
Begin VB.Menu mnuF0Main
Caption = "&File"
Begin VB.Menu mnuFile
Caption = "&Open..."
Index = 0
Shortcut = ^O
End
Begin VB.Menu mnuFile
Caption = "&Save"
Index = 1
Shortcut = ^S
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 2
End
Begin VB.Menu mnuFile
Caption = "&Print..."
Index = 3
Shortcut = ^P
End
Begin VB.Menu mnuFile
Caption = "Print Se&tup..."
Index = 4
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 5
Visible = 0 'False
End
Begin VB.Menu mnuFile
Caption = "&1) Test Invisible 1"
Checked = -1 'True
Index = 6
Visible = 0 'False
End
Begin VB.Menu mnuFile
Caption = "&2) Test Invisible 2"
Index = 7
Visible = 0 'False
End
Begin VB.Menu mnuFile
Caption = "&3) Test Invisible 3"
Index = 8
Visible = 0 'False
End
Begin VB.Menu mnuFile
Caption = "&4) Test Invisible 4"
Index = 9
Visible = 0 'False
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 10
End
Begin VB.Menu mnuFile
Caption = "E&xit"
Index = 11
Shortcut = ^Q
End
End
Begin VB.Menu mnuE0MAIN
Caption = "&Edit"
Begin VB.Menu mnuEdit
Caption = "Cu&t"
Index = 0
Shortcut = ^X
End
Begin VB.Menu mnuEdit
Caption = "&Copy"
Index = 1
Shortcut = ^C
End
Begin VB.Menu mnuEdit
Caption = "&Paste"
Index = 2
Shortcut = ^V
End
Begin VB.Menu mnuEdit
Caption = "-"
Index = 3
End
Begin VB.Menu mnuEdit
Caption = "Search..."
Index = 4
End
End
Begin VB.Menu mnuPop
Caption = "&In Code"
Begin VB.Menu mnuSub
Caption = ""
Index = 0
End
End
Begin VB.Menu mnuH0MAIN
Caption = "&Help"
Begin VB.Menu mnuHelp
Caption = "&Contents..."
Index = 0
Shortcut = {F1}
End
Begin VB.Menu mnuHelp
Caption = "&On the Internet..."
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 = "frmTest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private cIM As New cIconMenu
Private Sub pCreateMenuItems()
Dim lParentIndex As Long
Dim lIndex As Long
Dim lThisIndex As Long
Dim sPath As String
mnuSub(0).Caption = "Move to the Previous page"
Load mnuSub(1)
mnuSub(1).Visible = True
mnuSub(1).Caption = "Test"
Load mnuSub(2)
mnuSub(2).Visible = True
mnuSub(2).Caption = "Test2"
Load mnuSub(3)
mnuSub(3).Visible = True
mnuSub(3).Caption = "-"
Load mnuSub(4)
mnuSub(4).Visible = True
mnuSub(4).Caption = "Most &Viewed"
Load mnuSub(5)
mnuSub(5).Visible = True
mnuSub(5).Caption = "Ne&west"
Load mnuSub(6)
mnuSub(6).Visible = True
mnuSub(6).Caption = "-"
Load mnuSub(7)
mnuSub(7).Visible = True
mnuSub(7).Caption = "Trace &History"
mnuSub(7).Checked = True
End Sub
Private Sub chkBackground_Click()
If (chkBackground.Value = Checked) Then
Set cIM.BackgroundPicture = picBackground.Picture
Else
Set cIM.BackgroundPicture = Nothing
End If
End Sub
Private Sub chkCustomColours_Click()
If chkCustomColours.Value = Checked Then
With cIM
.MenuBackgroundColor = &HCC9966
.ActiveMenuForeColor = &HFFFFFF
.InActiveMenuForeColor = &HFFFFCC
Set .Font = Me.Font
End With
Else
With cIM
' CLR_INVALID (=-1) = use default
.MenuBackgroundColor = -1
.ActiveMenuForeColor = -1
.InActiveMenuForeColor = -1
Set .Font = Nothing
End With
End If
End Sub
Private Sub chkEnable_Click()
mnuEdit(2).Enabled = chkEnable.Value * -1
End Sub
Private Sub chkENewest_Click()
mnuSub(5).Enabled = chkENewest.Value * -1
End Sub
Private Sub chkNewest_Click()
mnuSub(5).Checked = (chkNewest.Value = Checked)
End Sub
Private Sub chkOfficeXPStyle_Click()
cIM.OfficeXpStyle = (chkOfficeXPStyle.Value = Checked)
End Sub
Private Sub cmdChangeCaption_Click()
If mnuEdit(2).Caption = "&Paste" Then
mnuEdit(2).Caption = "Replacement Caption for &Paste"
cIM.IconItemCaptionChanged "&Paste", mnuEdit(2).Caption
Else
cIM.IconItemCaptionChanged mnuEdit(2).Caption, "&Paste"
mnuEdit(2).Caption = "&Paste"
End If
lblCaption.Caption = mnuEdit(2).Caption
End Sub
Private Sub cmdMDIDemo_Click()
mfrmMDITest.Show
End Sub
Private Sub cmdUnload_Click()
mnuFile_Click 11
End Sub
Private Sub cmdVBPopup_Click()
Dim lLeft As Long
Dim lTop As Long
lLeft = cmdVBPopup.Left
lTop = cmdVBPopup.Top + cmdVBPopup.Height
Dim ctl As Control
Dim lErr As Long
Set ctl = cmdVBPopup
On Error Resume Next
Do
Set ctl = ctl.Container
lErr = Err.Number
If (lErr <> 0) Then
lLeft = lLeft + ctl.Left
lTop = lTop + ctl.Top
End If
Loop While (lErr = 0)
On Error GoTo 0
Me.PopupMenu mnuE0MAIN, , _
lLeft, _
lTop
End Sub
Private Sub cmdChangeIcon_Click()
Dim i As Long
i = Rnd * ilsIcons.ImageCount
cIM.IconIndex(mnuEdit(2).Caption) = i
picIcon.Picture = ilsIcons.ItemPicture(i + 1)
End Sub
Private Sub cmdVisible_Click()
Static i As Long
'
' Make one of the invisible menu items
' visible again:
If (i = 0) Then
i = 5
Else
i = i + 1
End If
If (i = 9) Then
cmdVisible.Enabled = False
End If
' Make menu item visible:
mnuFile(i).Visible = True
If i = 5 Then
cmdVisible_Click
End If
End Sub
Private Sub Form_Load()
Dim l As Long
Dim lIndex As Long
Dim lC As Long
Set cIM = New cIconMenu
With cIM
.Attach Me.hwnd
.OfficeXpStyle = True
.ImageList = ilsIcons
.IconIndex(mnuFile(0).Caption) = ilsIcons.ItemIndex("OPEN") - 1
.IconIndex(mnuFile(1).Caption) = ilsIcons.ItemIndex("SAVE") - 1
.IconIndex(mnuFile(3).Caption) = ilsIcons.ItemIndex("PRINT") - 1
.IconIndex(mnuEdit(0).Caption) = ilsIcons.ItemIndex("CUT") - 1
.IconIndex(mnuEdit(1).Caption) = ilsIcons.ItemIndex("COPY") - 1
.IconIndex(mnuEdit(2).Caption) = ilsIcons.ItemIndex("PASTE") - 1
.IconIndex(mnuEdit(4).Caption) = ilsIcons.ItemIndex("BINOC") - 1
.IconIndex(mnuHelp(0).Caption) = ilsIcons.ItemIndex("HELP") - 1
.IconIndex(mnuHelp(1).Caption) = ilsIcons.ItemIndex("WEB_LINK") - 1
End With
' Add some new menu items in code:
pCreateMenuItems
End Sub
Private Sub mnuEdit_Click(Index As Integer)
MsgBox "Visual Basic Menu Edit Fired for Index:" & Index, vbInformation
End Sub
Private Sub mnuFile_Click(Index As Integer)
If (Index = 11) Then
If (vbYes = MsgBox("Are you sure you want to exit?", vbYesNo Or
vbQuestion)) Then
Unload Me
End If
Else
MsgBox "Visual Basic Menu File Fired for Index:" & Index, vbInformation
End If
End Sub
Private Sub mnuHelp_Click(Index As Integer)
MsgBox "Visual Basic Help Menu Fired for Index:" & Index, vbInformation
End Sub
Private Sub optButtonSelect_Click(Index As Integer)
Select Case True
Case optButtonSelect(0).Value
cIM.HighlightStyle = ECPHighlightStyleStandard
Case optButtonSelect(1).Value
cIM.HighlightStyle = ECPHighlightStyleGradient
Case optButtonSelect(2).Value
cIM.HighlightStyle = ECPHighlightStyleButton
End Select
End Sub
Private Sub picIcon_Click()
Dim i As Long
Dim lIndex As Long
For i = 0 To Controls.Count - 1
Debug.Print Controls(i).Name,
If TypeOf Controls(i) Is Menu Then
Debug.Print Controls(i).Caption;
Else
Debug.Print
End If
On Error Resume Next
lIndex = Controls(i).Index
If (Err.Number = 0) Then
Debug.Print lIndex
End If
Next i
End Sub
