Option Explicit
Option Base 1
'---------------------------------------------------------------------------------------
' Module : basMenuAPIMNU
' DateTime : 05/01/05 14:33
' Author : Ivan F Moala
' Site : http://www.xcelfiles.com
' Purpose : Creates Windows Menu using API's
'---------------------------------------------------------------------------------------
'// Creates a horizontal menu bar @ the top, suitable for attaching to a top-level window.
'// eg [File], [Edit] etc and usually ending in Help
'// That's the Basic Format.. with [Windows] usually 2nd to last.
Public Declare Function CreateMenu _
Lib "user32" () _
As Long
Public Declare Function CreatePopupMenu _
Lib "user32" () _
As Long
Public Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As Long
Public Declare Function GetMenu _
Lib "user32" ( _
ByVal hwnd As Long) _
As Long
Public Declare Function AppendMenu _
Lib "user32" _
Alias "AppendMenuA" ( _
ByVal hMenu As Long, _
ByVal wFlags As Long, _
ByVal wIDNewItem As Long, _
ByVal lpNewItem As String) _
As Long
Public Declare Function SetMenu _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hMenu As Long) _
As Long
Public Declare Function DestroyMenu _
Lib "user32" ( _
ByVal hMenu As Long) _
As Long
Public Declare Function SetWindowLong _
Lib "user32" _
Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) _
As Long
Public Const MF_SEPARATOR As Long = &H800&
Public Const MF_POPUP = &H10
Public Const MF_STRING = &H0
Public Const IDM_MU As Long = &H7D0 '// Our Menu Item ID
'//
Public g_hPopUpMenu() As Long '// Holds Popupmenu handles
Public g_hMenu As Long '// Userform menu handle
Public g_hPopUpSubMenu() As Long '// Holds Submenu handles
Public g_Rt() As Long '// Holds return Values for testing debuging
Public g_APIMacro() As String '// Holds Routine names associated with Menus
Public g_hForm As Long '// Userform handle
Public g_MNUSheet As Worksheet '// Menu Sheet
Public Sub CreateAPIMenu()
'// This sub should be executed when the Userform is Initialised.
Dim RowNum As Long, _
SubMNU As Long, _
TopMNUitems As Long, _
SubMNUItem As Long, _
TopMNU As Long, _
Rt As Long, _
MacroNum As Long
'// Set menusheet
Set g_MNUSheet = ThisWorkbook.Sheets("APIMNU")
With g_MNUSheet
'// Set-up now
TopMNUitems = .Range("A1") '// Number of Top Level
SubMNU = .Range("B1") '// Number of Sub Menus
ReDim g_hPopUpMenu(TopMNUitems) '//
ReDim g_Rt(TopMNUitems) '//
ReDim g_hPopUpSubMenu(SubMNU) '//
ReDim g_APIMacro(.Range("C1").Value) '//
'// Create Main Menu Area @ Top of Userform
g_hMenu = CreateMenu()
Rt = SetMenu(g_hForm, g_hMenu)
'// Initialize variables
RowNum = 0
MacroNum = 1
SubMNUItem = LBound(g_hPopUpSubMenu)
For TopMNU = 1 To TopMNUitems
RowNum = RowNum + 1
'// AppendMenu(g_hMenu, MF_POPUP, hPopUpMenu1, "&File")
'// Create our Top Menu
g_hPopUpMenu(TopMNU) = CreatePopupMenu()
'// For 1st Menu Index is (2 + RowNum) after which it is (1 + RowNum)
If TopMNU = 1 Then
g_Rt(TopMNU) = AppendMenu(g_hMenu, MF_POPUP, g_hPopUpMenu(TopMNU), .Cells(2 + RowNum, 2))
Else
g_Rt(TopMNU) = AppendMenu(g_hMenu, MF_POPUP, g_hPopUpMenu(TopMNU), .Cells(1 + RowNum, 2))
End If
'// Do until we get to the END of the Menu = New TOP LEVEL MENU Starts!
Do Until .Cells(2 + RowNum, 4).Text = "END"
Select Case .Cells(2 + RowNum, 1).Value
Case 1
'// Do nothing for Testing
Case 0
'// Menu Seperator/Divider ... IDM_MU + Cells(2 + RowNum, 5)
'// AppendMenu(hPopUpMenu1, MF_SEPARATOR, IDM_MU + num, vbNullString)
'// If it is within Submenu to a Submenu then....
If .Cells(1 + RowNum, 1) = 4 Then
g_Rt(TopMNU) = AppendMenu(g_hPopUpSubMenu(SubMNUItem - 1), _
MF_SEPARATOR, &O0, vbNullString)
Else
g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), _
MF_SEPARATOR, &O1, vbNullString)
End If
Case 2
'// STD Sub
'// AppendMenu(hPopUpMenu1, MF_STRING, IDM_MU + num, " &New task (Run...)")
g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_STRING, _
IDM_MU + .Cells(2 + RowNum, 5), .Cells(2 + RowNum, 2))
'// Update our Routine to Run here
g_APIMacro(MacroNum) = .Cells(2 + RowNum, 3).Text
MacroNum = MacroNum + 1
Case 3
'// A SUBMENU Caption = 3
g_hPopUpSubMenu(SubMNUItem) = CreatePopupMenu()
'// AppendMenu(g_hMenu, MF_POPUP, hPopUpSubMenu1, vbNullString)
g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_POPUP, _
g_hPopUpSubMenu(SubMNUItem), .Cells(2 + RowNum, 2))
SubMNUItem = SubMNUItem + 1
Case 4
'// A SUBMENUITEM = 4
'// AppendMenu(hPopUpSubMenu1, MF_STRING, IDM_MU + num, "SubMNU &1")
'// OK, lets build our sub Menu
g_Rt(TopMNU) = AppendMenu(g_hPopUpSubMenu(SubMNUItem - 1), _
MF_STRING, IDM_MU + .Cells(2 + RowNum, 5), .Cells(2 + RowNum, 2))
'// Update our Routine to Run here
g_APIMacro(MacroNum) = .Cells(2 + RowNum, 3).Text
MacroNum = MacroNum + 1
End Select
RowNum = RowNum + 1
Loop
Next TopMNU
End With
End Sub
Public Sub RunAPIMNUMacro(strMacroName As String)
On Error Resume Next
Application.Run (strMacroName)
If Err Then
MsgBox "Error number:=" & Err.Number & vbCrLf & _
"Description:=" & Err.Description & vbCrLf & _
"Check yur macro names!", vbCritical + vbMsgBoxHelpButton, _
"Menu Macro Error", Err.HelpFile, Err.HelpContext
End If
Err.Clear
End Sub
