Hello,
I have come across this code in order to set a menubar with popups on a userform in my 32bit excel app.
Once trying to incorporate it in my other pc which has 64bit excel it is always giving me "type mismatch error" for the AddressOf .
Much appreciated in advance for any assistance.
Kind Regards
MDYusf
USERFORM CODE :
Option Explicit
Private Declare PtrSafe Function ExibirÍcone Lib "user32" Alias "SendMessageA" ( _
ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
'...............................................................................
'...............................................................................
Private Declare PtrSafe Function IniciaJanela Lib "user32" Alias "GetWindowLongA" ( _
ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function MoveJanela Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, _
ByVal nCmdShow As Long) As Long
'...............................................................................
'...............................................................................
Private Const FOCO_ICONE = &H80
Private Const ICONE = 0&
'Private Const GRANDE_ICONE = 1&
Private Const ESTILO_PROLONGADO = (-20)
Private Const ESTILO_ATUAL As Long = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_BARRA_TAREFAS = &H40000
Private Const WS_MENU As Long = &H80000
Private Const WS_CX_MINIMIZAR As Long = &H20000
Private Const WS_CX_MAXIMIZAR As Long = &H10000
Private Const WS_POPUP As Long = &H80000000
Private Const SW_EXIBIR_NORMAL = 1
Private Const SW_EXIBIR_MINIMIZADO = 2
Private Const SW_EXIBIR_MAXIMIZADO = 3
Dim Form_Personalizado As Long
Dim ESTILO As Long
Dim hIcone As Long
Dim Vazio, Vazio2, Vazio3, Vazio4 As Boolean
Private Sub UserForm_Activate()
Form_Personalizado = FindWindowA(vbNullString, Me.Caption)
ESTILO = IniciaJanela(Form_Personalizado, ESTILO_ATUAL)
ESTILO = ESTILO Or WS_MENU '// Menu
ESTILO = ESTILO Or WS_CX_MINIMIZAR '// Botão Minimizar
ESTILO = ESTILO Or WS_CX_MAXIMIZAR '// Botão Minimizar
ESTILO = ESTILO Or WS_POPUP '
ESTILO = ESTILO Or WS_CAPTION
MoveJanela Form_Personalizado, ESTILO_ATUAL, (ESTILO)
ESTILO = IniciaJanela(Form_Personalizado, ESTILO_PROLONGADO)
ESTILO = ESTILO Or WS_BARRA_TAREFAS
MoveJanela Form_Personalizado, ESTILO_PROLONGADO, ESTILO
'hIcone = Image1.Picture.Handle
'Call ExibirÍcone(Form_Personalizado, FOCO_ICONE, ICONE, ByVal hIcone)
DrawMenuBar Form_Personalizado
SetFocus Form_Personalizado
ShowWindow Form_Personalizado, 1 'SW_EXIBIR_NORMAL
'----------------------------------------------------------------------------
End Sub
Private Sub UserForm_Initialize()
g_hForm = FindWindow(vbNullString, Me.Caption)
Call CreateAPIMenu
#If VBA6 Then
g_lpMyWndProc = SetWindowLong(g_hForm, GWL_WNDPROC, AddressOf HookWinProc)
#Else
g_lpMyWndProc = SetWindowLong(g_hForm, GWL_WNDPROC, AddrOf("HookWinProc"))
#End If
'// Work around for Windows repaint
With Me
.Height = 34 ' 250 - 45
.Width = 380 ' Original + 19
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'// Clean up
DestroyMenu g_hMenu
SetWindowLong g_hForm, GWL_WNDPROC, g_lpMyWndProc
End Sub
Private Sub UserForm_Terminate()
'// Safety Clean up
DestroyMenu g_hMenu
SetWindowLong g_hForm, GWL_WNDPROC, g_lpMyWndProc
End Sub
basAPIMNU Module Code :
Option Explicit
Option Base 1
Public Declare PtrSafe 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
Public Declare PtrSafe Function CreateMenu Lib "user32" () As Long
Public Declare PtrSafe Function CreatePopupMenu Lib "user32" () As Long
Public Declare PtrSafe 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 PtrSafe Function SetMenu Lib "user32" ( _
ByVal hWnd As Long, _
ByVal hMenu As Long) As Long
Public Declare PtrSafe Function DestroyMenu Lib "user32" ( _
ByVal hMenu As Long) As Long
Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong 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 Const MF_SEPARATOR As Long = &H800&
Public Const MF_POPUP = &H10
Public Const MF_STRING = &H0
Public Const IDM_MU As Long = &H7D0
Public g_hPopUpMenu() As Long
Public g_hMenu As Long
Public g_hPopUpSubMenu() As Long
Public g_Rt() As Long
Public g_APIMacro() As String
Public g_hForm As Long
Public g_MNUSheet As Worksheet
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-up now
TopMNUitems = 9 '// Number of Top Level
SubMNU = 7 '// Maximum allowed number of added Sub Menus
Dim MenuNum As Long
ReDim g_hPopUpMenu(TopMNUitems) '//
ReDim g_Rt(TopMNUitems) '//
ReDim g_hPopUpSubMenu(SubMNU) '//
ReDim g_APIMacro(99) '// Maximum allowed number of added popups in submenus
Dim MainTitles As String
'// 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)
TopMNU = 1 'Menu Number
MainTitles = "File"
g_hPopUpMenu(TopMNU) = CreatePopupMenu()
g_Rt(TopMNU) = AppendMenu(g_hMenu, MF_POPUP, g_hPopUpMenu(TopMNU), MainTitles)
MenuNum = 10 ' Starting Count For Reference
g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_STRING, IDM_MU + MenuNum, "Export Data") 'SubMenu Title Here
g_APIMacro(MenuNum) = "Menu1" 'Sub Name Here
MenuNum = MenuNum + 1
g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_STRING, IDM_MU + MenuNum, "Import Data") 'SubMenu Title Here
g_APIMacro(MenuNum) = "Menu2" 'Sub Name Here
MenuNum = MenuNum + 1
g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_STRING, IDM_MU + MenuNum, "Reset Data") 'SubMenu Title Here
g_APIMacro(MenuNum) = "Menu4" 'Sub Name Here
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
Public Function HookWinProc(ByVal hw As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WM_COMMAND Then
DoEvents
Call RunAPIMNUMacro(g_APIMacro(wParam - IDM_MU))
End If
HookWinProc = CallWindowProc(g_lpMyWndProc, hw, uMsg, wParam, lParam)
End Function
basAddrOf module Code :
Option Explicit
Private Declare PtrSafe Function GetCurrentVbaProject Lib "vba332.dll" Alias "EbGetExecutingProj" (hProject As Long) As Long
Private Declare PtrSafe Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" ( _
ByVal hProject As Long, _
ByVal strFunctionName As String, _
ByRef strFunctionId As String) _
As Long
Private Declare PtrSafe Function GetAddr Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" ( _
ByVal hProject As Long, _
ByVal strFunctionId As String, _
ByRef lpfn As Long) _
As Long
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
Const NO_ERROR = 0
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
Call GetCurrentVbaProject(hProject)
If hProject <> 0 Then
lngResult = GetFuncID( _
hProject, strFuncNameUnicode, strID)
If lngResult = NO_ERROR Then
lngResult = GetAddr(hProject, strID, lpfn)
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
End Function
I have come across this code in order to set a menubar with popups on a userform in my 32bit excel app.
Once trying to incorporate it in my other pc which has 64bit excel it is always giving me "type mismatch error" for the AddressOf .
Much appreciated in advance for any assistance.
Kind Regards
MDYusf
USERFORM CODE :
Option Explicit
Private Declare PtrSafe Function ExibirÍcone Lib "user32" Alias "SendMessageA" ( _
ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
'...............................................................................
'...............................................................................
Private Declare PtrSafe Function IniciaJanela Lib "user32" Alias "GetWindowLongA" ( _
ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function MoveJanela Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, _
ByVal nCmdShow As Long) As Long
'...............................................................................
'...............................................................................
Private Const FOCO_ICONE = &H80
Private Const ICONE = 0&
'Private Const GRANDE_ICONE = 1&
Private Const ESTILO_PROLONGADO = (-20)
Private Const ESTILO_ATUAL As Long = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_BARRA_TAREFAS = &H40000
Private Const WS_MENU As Long = &H80000
Private Const WS_CX_MINIMIZAR As Long = &H20000
Private Const WS_CX_MAXIMIZAR As Long = &H10000
Private Const WS_POPUP As Long = &H80000000
Private Const SW_EXIBIR_NORMAL = 1
Private Const SW_EXIBIR_MINIMIZADO = 2
Private Const SW_EXIBIR_MAXIMIZADO = 3
Dim Form_Personalizado As Long
Dim ESTILO As Long
Dim hIcone As Long
Dim Vazio, Vazio2, Vazio3, Vazio4 As Boolean
Private Sub UserForm_Activate()
Form_Personalizado = FindWindowA(vbNullString, Me.Caption)
ESTILO = IniciaJanela(Form_Personalizado, ESTILO_ATUAL)
ESTILO = ESTILO Or WS_MENU '// Menu
ESTILO = ESTILO Or WS_CX_MINIMIZAR '// Botão Minimizar
ESTILO = ESTILO Or WS_CX_MAXIMIZAR '// Botão Minimizar
ESTILO = ESTILO Or WS_POPUP '
ESTILO = ESTILO Or WS_CAPTION
MoveJanela Form_Personalizado, ESTILO_ATUAL, (ESTILO)
ESTILO = IniciaJanela(Form_Personalizado, ESTILO_PROLONGADO)
ESTILO = ESTILO Or WS_BARRA_TAREFAS
MoveJanela Form_Personalizado, ESTILO_PROLONGADO, ESTILO
'hIcone = Image1.Picture.Handle
'Call ExibirÍcone(Form_Personalizado, FOCO_ICONE, ICONE, ByVal hIcone)
DrawMenuBar Form_Personalizado
SetFocus Form_Personalizado
ShowWindow Form_Personalizado, 1 'SW_EXIBIR_NORMAL
'----------------------------------------------------------------------------
End Sub
Private Sub UserForm_Initialize()
g_hForm = FindWindow(vbNullString, Me.Caption)
Call CreateAPIMenu
#If VBA6 Then
g_lpMyWndProc = SetWindowLong(g_hForm, GWL_WNDPROC, AddressOf HookWinProc)
#Else
g_lpMyWndProc = SetWindowLong(g_hForm, GWL_WNDPROC, AddrOf("HookWinProc"))
#End If
'// Work around for Windows repaint
With Me
.Height = 34 ' 250 - 45
.Width = 380 ' Original + 19
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'// Clean up
DestroyMenu g_hMenu
SetWindowLong g_hForm, GWL_WNDPROC, g_lpMyWndProc
End Sub
Private Sub UserForm_Terminate()
'// Safety Clean up
DestroyMenu g_hMenu
SetWindowLong g_hForm, GWL_WNDPROC, g_lpMyWndProc
End Sub
basAPIMNU Module Code :
Option Explicit
Option Base 1
Public Declare PtrSafe 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
Public Declare PtrSafe Function CreateMenu Lib "user32" () As Long
Public Declare PtrSafe Function CreatePopupMenu Lib "user32" () As Long
Public Declare PtrSafe 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 PtrSafe Function SetMenu Lib "user32" ( _
ByVal hWnd As Long, _
ByVal hMenu As Long) As Long
Public Declare PtrSafe Function DestroyMenu Lib "user32" ( _
ByVal hMenu As Long) As Long
Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong 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 Const MF_SEPARATOR As Long = &H800&
Public Const MF_POPUP = &H10
Public Const MF_STRING = &H0
Public Const IDM_MU As Long = &H7D0
Public g_hPopUpMenu() As Long
Public g_hMenu As Long
Public g_hPopUpSubMenu() As Long
Public g_Rt() As Long
Public g_APIMacro() As String
Public g_hForm As Long
Public g_MNUSheet As Worksheet
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-up now
TopMNUitems = 9 '// Number of Top Level
SubMNU = 7 '// Maximum allowed number of added Sub Menus
Dim MenuNum As Long
ReDim g_hPopUpMenu(TopMNUitems) '//
ReDim g_Rt(TopMNUitems) '//
ReDim g_hPopUpSubMenu(SubMNU) '//
ReDim g_APIMacro(99) '// Maximum allowed number of added popups in submenus
Dim MainTitles As String
'// 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)
TopMNU = 1 'Menu Number
MainTitles = "File"
g_hPopUpMenu(TopMNU) = CreatePopupMenu()
g_Rt(TopMNU) = AppendMenu(g_hMenu, MF_POPUP, g_hPopUpMenu(TopMNU), MainTitles)
MenuNum = 10 ' Starting Count For Reference
g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_STRING, IDM_MU + MenuNum, "Export Data") 'SubMenu Title Here
g_APIMacro(MenuNum) = "Menu1" 'Sub Name Here
MenuNum = MenuNum + 1
g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_STRING, IDM_MU + MenuNum, "Import Data") 'SubMenu Title Here
g_APIMacro(MenuNum) = "Menu2" 'Sub Name Here
MenuNum = MenuNum + 1
g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_STRING, IDM_MU + MenuNum, "Reset Data") 'SubMenu Title Here
g_APIMacro(MenuNum) = "Menu4" 'Sub Name Here
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
Public Function HookWinProc(ByVal hw As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WM_COMMAND Then
DoEvents
Call RunAPIMNUMacro(g_APIMacro(wParam - IDM_MU))
End If
HookWinProc = CallWindowProc(g_lpMyWndProc, hw, uMsg, wParam, lParam)
End Function
basAddrOf module Code :
Option Explicit
Private Declare PtrSafe Function GetCurrentVbaProject Lib "vba332.dll" Alias "EbGetExecutingProj" (hProject As Long) As Long
Private Declare PtrSafe Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" ( _
ByVal hProject As Long, _
ByVal strFunctionName As String, _
ByRef strFunctionId As String) _
As Long
Private Declare PtrSafe Function GetAddr Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" ( _
ByVal hProject As Long, _
ByVal strFunctionId As String, _
ByRef lpfn As Long) _
As Long
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
Const NO_ERROR = 0
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
Call GetCurrentVbaProject(hProject)
If hProject <> 0 Then
lngResult = GetFuncID( _
hProject, strFuncNameUnicode, strID)
If lngResult = NO_ERROR Then
lngResult = GetAddr(hProject, strID, lpfn)
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
End Function
