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: mfrmTest.frm
VERSION 5.00
Object = "{396F7AC0-A0DD-11D3-93EC-00C0DFE7442A}#1.0#0"; "vbalIml6.ocx"
Begin VB.MDIForm mfrmMDITest
BackColor = &H8000000C&
Caption = "Test PopMenu Control in MDI Form"
ClientHeight = 5040
ClientLeft = 1710
ClientTop = 2085
ClientWidth = 6870
Icon = "mfrmTest.frx":0000
LinkTopic = "MDIForm1"
Begin VB.PictureBox picStatus
Align = 2 'Align Bottom
BorderStyle = 0 'None
Height = 315
Left = 0
ScaleHeight = 315
ScaleWidth = 6870
TabIndex = 0
Top = 4725
Width = 6870
Begin VB.Label lblStatus
Height = 255
Left = 60
TabIndex = 1
Top = 60
Width = 6795
End
End
Begin vbalIml6.vbalImageList ilsIcons
Left = 240
Top = 360
_ExtentX = 953
_ExtentY = 953
Size = 19516
Images = "mfrmTest.frx":030A
Version = 131072
KeyCount = 17
Keys =
"NEWOPENSAVEPRINTCUTCOPYPASTEBINOCHELPKILLWINPREVWINNEXTWINMOREWINSTILEVE
RTTILEHORZCASCADEWEB_LINK"
End
Begin VB.Menu mnuFileTOP
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
Shortcut = ^O
End
Begin VB.Menu mnuFile
Caption = "&Save..."
Index = 3
Shortcut = ^S
End
Begin VB.Menu mnuFile
Caption = "Save &As"
Index = 4
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 5
End
Begin VB.Menu mnuFile
Caption = "&Print"
Index = 6
Shortcut = ^P
End
Begin VB.Menu mnuFile
Caption = "Print Pre&view"
Index = 7
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 8
End
Begin VB.Menu mnuFile
Caption = "P&roperties"
Index = 9
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 10
End
Begin VB.Menu mnuFile
Caption = "E&xit"
Index = 11
End
End
Begin VB.Menu mnuWindowTOP
Caption = "&Window"
WindowList = -1 'True
Begin VB.Menu mnuWindow
Caption = "&Cascade"
Index = 0
End
Begin VB.Menu mnuWindow
Caption = "Tile &Horizontally"
Index = 1
End
Begin VB.Menu mnuWindow
Caption = "Tile &Vertically"
Index = 2
End
Begin VB.Menu mnuWindow
Caption = "Close &All"
Index = 3
End
Begin VB.Menu mnuWindow
Caption = "-"
Index = 4
End
Begin VB.Menu mnuWindow
Caption = "&Next Window"
Index = 5
End
Begin VB.Menu mnuWindow
Caption = "&Previous Window"
Index = 6
End
End
Begin VB.Menu mnuHelpTOP
Caption = "&Help"
Begin VB.Menu mnuHelp
Caption = "&Contents..."
Index = 0
Shortcut = {F1}
End
Begin VB.Menu mnuHelp
Caption = "-"
Index = 1
End
Begin VB.Menu mnuHelp
Caption = "&About..."
Index = 2
End
End
End
Attribute VB_Name = "mfrmMDITest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private cIM As New cIconMenu
Private m_lAboutId As Long
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA"
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
Long) As Long
Private Const WM_MDINEXT = &H224
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal
hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As
String) As Long
Private Function GetMDIClienthWnd() As Long
GetMDIClienthWnd = FindWindowEx(Me.hwnd, 0, "MDIClient", vbNullString)
End Function
Private Sub MDIForm_Load()
Dim l As Long
Dim lIndex As Long
Dim lC As Long
With cIM
.Attach Me.hwnd
.OfficeXpStyle = True
.ImageList = ilsIcons
.IconIndex(mnuFile(0).Caption) = ilsIcons.ItemIndex("NEW") - 1
.IconIndex(mnuFile(2).Caption) = ilsIcons.ItemIndex("OPEN") - 1
.IconIndex(mnuFile(3).Caption) = ilsIcons.ItemIndex("SAVE") - 1
.IconIndex(mnuFile(6).Caption) = ilsIcons.ItemIndex("PRINT") - 1
.IconIndex(mnuFile(7).Caption) = ilsIcons.ItemIndex("BINOC") - 1
.IconIndex(mnuWindow(0).Caption) = ilsIcons.ItemIndex("CASCADE") - 1
.IconIndex(mnuWindow(1).Caption) = ilsIcons.ItemIndex("TILEHORZ") - 1
.IconIndex(mnuWindow(2).Caption) = ilsIcons.ItemIndex("TILEVERT") - 1
.IconIndex(mnuWindow(3).Caption) = ilsIcons.ItemIndex("KILLWIN") - 1
.IconIndex(mnuWindow(5).Caption) = ilsIcons.ItemIndex("NEXTWIN") - 1
.IconIndex(mnuWindow(6).Caption) = ilsIcons.ItemIndex("PREVWIN") - 1
.IconIndex("&More Windows...") = ilsIcons.ItemIndex("MOREWINS") - 1
.IconIndex(mnuHelp(0).Caption) = ilsIcons.ItemIndex("HELP") - 1
End With
mnuFile_Click 0
End Sub
Private Sub mnuFile_Click(Index As Integer)
Select Case Index
Case 0
Dim f As frmMDIChild
Set f = New frmMDIChild
f.Show
Case 2
Case 3
Case 4
Case 6
Case 7
Case 9
Case 11
Unload Me
End Select
End Sub
Private Sub mnuFileTOP_Click()
Dim bS As Boolean
bS = Not (Me.ActiveForm Is Nothing)
mnuFile(3).Enabled = bS
mnuFile(4).Enabled = bS
mnuFile(6).Enabled = bS
mnuFile(7).Enabled = bS
mnuFile(9).Enabled = bS
End Sub
Private Sub mnuWindow_Click(Index As Integer)
Dim lhWNd As Long
Select Case Index
Case 0
Me.Arrange vbCascade
Case 1
Me.Arrange vbTileHorizontal
Case 2
Me.Arrange vbTileVertical
Case 3
Dim f As Object
For Each f In Forms
On Error Resume Next
If f.MDIChild Then
If Err.Number = 0 Then
Unload f
End If
End If
Err.Clear
Next
Case 5
lhWNd = GetMDIClienthWnd()
SendMessageLong lhWNd, WM_MDINEXT, 0, 0
Case 6
lhWNd = GetMDIClienthWnd()
SendMessageLong lhWNd, WM_MDINEXT, 0, 1
End Select
End Sub
Private Sub mnuWindowTOP_Click()
Dim f As Object
Dim l As Long
For Each f In Forms
On Error Resume Next
If f.MDIChild Then
If Err.Number = 0 Then
l = l + 1
End If
End If
Err.Clear
Next
mnuWindow(0).Enabled = (l > 0)
mnuWindow(1).Enabled = (l > 0)
mnuWindow(2).Enabled = (l > 0)
mnuWindow(3).Enabled = (l > 0)
mnuWindow(5).Enabled = (l > 1)
mnuWindow(6).Enabled = (l > 1)
End Sub
