Menu bar 64bit code error

MDYusuf

New Member
Joined
Mar 25, 2022
Messages
17
Office Version
  1. 2021
Platform
  1. Windows
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
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).

ISY

Active Member
Joined
Nov 16, 2009
Messages
357
Hi

On 64 Bit

Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As LongPtr, _
ByVal nIndex As LongPtr, _
ByVal dwNewLong As LongPtr) As Long
 
Upvote 0

MDYusuf

New Member
Joined
Mar 25, 2022
Messages
17
Office Version
  1. 2021
Platform
  1. Windows
Hi

On 64 Bit

Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As LongPtr, _
ByVal nIndex As LongPtr, _
ByVal dwNewLong As LongPtr) As Long
Thanks @ ISY, i have changes and the error solved and able to see userform but file menu not working when i click save, there is nothing happen..looks the macro not function. Please advise if able to click file menu such us file>open>other userform.. which one i need to change.

I hope able to see the file menu working

Regards
MD
 
Upvote 0

Forum statistics

Threads
1,186,743
Messages
5,959,507
Members
438,429
Latest member
Ekana99

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top