Option Explicit
Public glb_origCalculationMode As Integer
Option Base 1
'---------------------------------------------------------------------------------------
' Module : basMenuAPIMNU
' DateTime : 05/01/05 14:33
' Author : Ivan F Moala
' Site : [URL]http://www.xcelfiles.com[/URL]
' 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
' KHAI BAO HAM API FINDWINDOWA TRONG THU VIEN USER32
' Mo ta: LAY handle cua cua so co ten (title) hoac class name trong trong chuoi duc chi dinh.
'KHAI BAO HAM API GETWINDOWLONGA TRONG THU VIEN USER32
'GetWindowLong lay ve mot gia tri 32 bit tu phan thong tin ve mot cua so
'KHAI BAO HAM API SETWINDOWLONGA TRONG THU VIEN USER32
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
'Thiet dat thông tin trong cau truc cua so
' Giá tri tra ve: neu thành công hàm tra ve giá tri truoc dó.
Public Const GWL_STYLE As Long = (-16) 'Thiet lap kieu cua so mo rong cho cua so.
Public Const WS_MAXIMIZEBOX As Long = &H10000 'Minimize box tren title bar
Public Const WS_MINIMIZEBOX = &H20000 'Maximize box tren title bar
Public Declare Function CallWindowProc _
Lib "user32" _
Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
Private Const WM_COMMAND = &H111
Private Const WM_MENUSELECT As Long = &H11F ''
Public g_lpMyWndProc As Long
Public Const GWL_WNDPROC = (-4)
Public Function HookWinProc(ByVal hw As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
'// Windows will handle all messages for you.
'// It's the WM_COMMAND that is the end result of the user selecting a menu choice.
'// Catch the WM_COMMAND message and do something......
'// When the user selects a menu item from your menu,
'// the command ID selected is sent to your window in the WPARAM field.
'// This allows you to take the correct action for the command.
If uMsg = WM_COMMAND Then
'// This is where we catch the Menu selection
DoEvents
'// You need to match the case with the Menu ID number
Call RunAPIMNUMacro(g_APIMacro(wParam - IDM_MU))
End If
'// NB:Pass all messages to the native window procedure to handle other msgs
HookWinProc = CallWindowProc(g_lpMyWndProc, hw, uMsg, wParam, lParam)
End Function
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("menu")
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
[COLOR=red]Public Sub RunAPIMNUMacro(strMacroName As String)[/COLOR]
[COLOR=red] On Error Resume Next[/COLOR]
[COLOR=red] Application.Run (strMacroName)[/COLOR]
[COLOR=red] If Err Then[/COLOR]
[COLOR=red] MsgBox "Error number:=" & Err.Number & vbCrLf & "Description:=" & Err.Description & vbCrLf & "Check yur macro names!", vbCritical + vbMsgBoxHelpButton, "Menu Macro Error", Err.HelpFile, Err.HelpContext[/COLOR]
[COLOR=red] End If[/COLOR]
[COLOR=red] Err.Clear[/COLOR]
[COLOR=red]End Sub[/COLOR]
