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 = "{396F7AC0-A0DD-11D3-93EC-00C0DFE7442A}#1.0#0"; "vbalIml6.ocx"
Begin VB.Form frmTest
Caption = "vbAccelerator IconMenu DLL - Add Icons to VB Menus"
ClientHeight = 5790
ClientLeft = 4110
ClientTop = 4590
ClientWidth = 5460
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 = 5790
ScaleWidth = 5460
Begin vbalIml6.vbalImageList ilsIcons
Left = 360
Top = 4380
_ExtentX = 953
_ExtentY = 953
Size = 10332
Images = "fMenuTst.frx":030A
Version = 131072
KeyCount = 9
Keys = "OPENSAVEPRINTCUTCOPYPASTEBINOCHELPWEB_LINK"
End
Begin VB.PictureBox picStatus
Align = 2 'Align Bottom
BorderStyle = 0 'None
Height = 855
Left = 0
ScaleHeight = 855
ScaleWidth = 5460
TabIndex = 25
Top = 4935
Width = 5460
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":2B86
ScaleHeight = 330
ScaleWidth = 1275
TabIndex = 27
ToolTipText = "Free, Advanced source code for VB Programmers at
http://vbaccelerator.com"
Top = 60
Width = 1335
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 = 28
Top = 60
Width = 3915
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 = 480
Width = 8235
End
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 = 1875
Left = 2760
TabIndex = 6
Top = 2520
Width = 2595
Begin VB.PictureBox Picture1
BorderStyle = 0 'None
Height = 1575
Left = 120
ScaleHeight = 1575
ScaleWidth = 2400
TabIndex = 7
Top = 240
Width = 2400
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 = 0
TabIndex = 31
Top = 780
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 = 0
TabIndex = 30
Top = 1020
Width = 2295
End
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 = 0
TabIndex = 29
Top = 1260
Value = 1 'Checked
Width = 2295
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 = 0
TabIndex = 10
Top = 0
Value = -1 'True
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 = 0
TabIndex = 9
Top = 240
Width = 2415
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 = 0
TabIndex = 8
Top = 480
Width = 2415
End
End
End
Begin VB.Frame fraMore
Caption = "Another Demonstration Form:"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1515
Left = 2760
TabIndex = 4
Top = 900
Width = 2595
Begin VB.PictureBox Picture4
BorderStyle = 0 'None
Height = 1155
Left = 60
ScaleHeight = 1155
ScaleWidth = 2415
TabIndex = 21
Top = 240
Width = 2415
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 = 22
Top = 180
Width = 1155
End
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 = 855
Left = 2760
TabIndex = 3
Top = 0
Width = 2595
Begin VB.PictureBox Picture3
BorderStyle = 0 'None
Height = 615
Left = 60
ScaleHeight = 615
ScaleWidth = 2475
TabIndex = 19
Top = 180
Width = 2475
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 = 180
TabIndex = 20
Top = 60
Width = 1155
End
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 = 1875
Left = 60
TabIndex = 2
Top = 2520
Width = 2595
Begin VB.PictureBox Picture5
BorderStyle = 0 'None
Height = 675
Left = 60
ScaleHeight = 675
ScaleWidth = 2475
TabIndex = 23
Top = 240
Width = 2475
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 = 240
TabIndex = 24
Top = 0
Width = 1155
End
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 = 2415
Left = 60
TabIndex = 1
Top = 0
Width = 2595
Begin VB.PictureBox Picture2
BorderStyle = 0 'None
Height = 2175
Left = 60
ScaleHeight = 2175
ScaleWidth = 2475
TabIndex = 11
Top = 180
Width = 2475
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 = 255
Left = 0
TabIndex = 17
Top = 600
Value = 1 'Checked
Width = 1515
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 = 0
TabIndex = 16
Top = 300
Width = 1515
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 = 0
TabIndex = 15
Top = 60
Width = 1395
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 = 240
TabIndex = 14
Top = 900
Width = 1155
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 = 240
TabIndex = 13
Top = 1500
Width = 1155
End
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 = 1500
ScaleHeight = 495
ScaleWidth = 555
TabIndex = 12
Top = 1500
Width = 615
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 = 555
Left = 1500
TabIndex = 18
Top = 900
Width = 915
End
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 = 4440
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 = 1620
Picture = "fMenuTst.frx":30DF
ScaleHeight = 1920
ScaleWidth = 1920
TabIndex = 5
Top = 3120
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"
Enabled = 0 'False
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 mnuInCodeMAIN
Caption = "In &Code"
Begin VB.Menu mnuSub
Caption = "<empty>"
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