Help !! Userform Menu Bar 64 bit

G

Googles

New Member
Joined
Dec 15, 2017
Messages
32
Hi Guys,
I am trying to convert this code from 32 bit to 64, but to no avail.
Please can anyone help me!

APIMenu.bas
VBA Code: 
Option Explicit
Option Base 1

Public Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As LongPtr, _
    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 LongPtr, _
    ByVal wFlags As Long, _
    ByVal wIDNewItem As Long, _
    ByVal lpNewItem As String) As Long

Public Declare PtrSafe Function SetMenu Lib "user32" ( _
    ByVal hWnd As LongPtr, _
    ByVal hMenu As LongPtr) As Long

Public Declare PtrSafe Function DestroyMenu Lib "user32" ( _
    ByVal hMenu As LongPtr) As Long

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

Private Const WM_COMMAND = &H111

Private Const WM_MENUSELECT As Long = &H11F

Public g_lpMyWndProc As LongPtr '//// 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 LongPtr  '//// Long
Public g_hPopUpSubMenu() As Long
Public g_Rt() As Long
Public g_APIMacro() As String
Public g_hForm As LongPtr '//// Long
Public g_MNUSheet As Worksheet

Public Sub CreateAPIMenu()
'// Este sub deve ser executado quando o Userform for inicializado
Dim RowNum As Long, _
    SubMNU As Long, _
    TopMNUitems As Long, _
    SubMNUItem As Long, _
    TopMNU As Long, _
    Rt As Long, _
    MacroNum As Long

'// A planilha Menu
Set g_MNUSheet = ThisWorkbook.Sheets("APIMNU")

With g_MNUSheet
    '//
    TopMNUitems = .Range("A1") '// Número do 1ºnível
    SubMNU = .Range("B1")      '// Numero dos Sub Menus
    
    ReDim g_hPopUpMenu(TopMNUitems)      '//
    ReDim g_Rt(TopMNUitems)              '//
    ReDim g_hPopUpSubMenu(SubMNU)        '//
    ReDim g_APIMacro(.Range("C1").Value) '//
    
    '// O Menu é criado no topo do Userform
    g_hMenu = CreateMenu()
    Rt = SetMenu(g_hForm, g_hMenu)
    
    '// Iniciando variáveis
    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()
        '//
        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 .Cells(2 + RowNum, 4).text = "FIM"
            Select Case .Cells(2 + RowNum, 1).Value
                Case 1
                    '
                Case 0
                    '//
                    '//
                    '//
                    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
                    '//
                    '//
                    g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_STRING, _
                        IDM_MU + .Cells(2 + RowNum, 5), .Cells(2 + RowNum, 2))
                    '// U
                    g_APIMacro(MacroNum) = .Cells(2 + RowNum, 3).text
                    MacroNum = MacroNum + 1
                Case 3
                    '
                    g_hPopUpSubMenu(SubMNUItem) = CreatePopupMenu()
                    
                    g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_POPUP, _
                        g_hPopUpSubMenu(SubMNUItem), .Cells(2 + RowNum, 2))
                    SubMNUItem = SubMNUItem + 1
                 Case 4
                    '
                    '
                    '
                    g_Rt(TopMNU) = AppendMenu(g_hPopUpSubMenu(SubMNUItem - 1), _
                        MF_STRING, IDM_MU + .Cells(2 + RowNum, 5), .Cells(2 + RowNum, 2))
                    '
                    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 "Erro nº:=" & Err.Number & vbCrLf & _
            "Descrição:=" & Err.Description & vbCrLf & _
            "Verifique os nomes das Macros!", vbCritical + vbMsgBoxHelpButton, _
            "Erro na Macro Menu", 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


Userform:
VBA Code: 
Option Explicit
Option Base 1

Public Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As LongPtr, _
    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 LongPtr, _
    ByVal wFlags As Long, _
    ByVal wIDNewItem As Long, _
    ByVal lpNewItem As String) As Long

Public Declare PtrSafe Function SetMenu Lib "user32" ( _
    ByVal hWnd As LongPtr, _
    ByVal hMenu As LongPtr) As Long

Public Declare PtrSafe Function DestroyMenu Lib "user32" ( _
    ByVal hMenu As LongPtr) As Long

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

Private Const WM_COMMAND = &H111

Private Const WM_MENUSELECT As Long = &H11F

Public g_lpMyWndProc As LongPtr '//// 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 LongPtr  '//// Long
Public g_hPopUpSubMenu() As Long
Public g_Rt() As Long
Public g_APIMacro() As String
Public g_hForm As LongPtr '//// Long
Public g_MNUSheet As Worksheet

Public Sub CreateAPIMenu()
'// Este sub deve ser executado quando o Userform for inicializado
Dim RowNum As Long, _
    SubMNU As Long, _
    TopMNUitems As Long, _
    SubMNUItem As Long, _
    TopMNU As Long, _
    Rt As Long, _
    MacroNum As Long

'// A planilha Menu
Set g_MNUSheet = ThisWorkbook.Sheets("APIMNU")

With g_MNUSheet
    '//
    TopMNUitems = .Range("A1") '// Número do 1ºnível
    SubMNU = .Range("B1")      '// Numero dos Sub Menus
    
    ReDim g_hPopUpMenu(TopMNUitems)      '//
    ReDim g_Rt(TopMNUitems)              '//
    ReDim g_hPopUpSubMenu(SubMNU)        '//
    ReDim g_APIMacro(.Range("C1").Value) '//
    
    '// O Menu é criado no topo do Userform
    g_hMenu = CreateMenu()
    Rt = SetMenu(g_hForm, g_hMenu)
    
    '// Iniciando variáveis
    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()
        '//
        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 .Cells(2 + RowNum, 4).text = "FIM"
            Select Case .Cells(2 + RowNum, 1).Value
                Case 1
                    '
                Case 0
                    '//
                    '//
                    '//
                    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
                    '//
                    '//
                    g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_STRING, _
                        IDM_MU + .Cells(2 + RowNum, 5), .Cells(2 + RowNum, 2))
                    '// U
                    g_APIMacro(MacroNum) = .Cells(2 + RowNum, 3).text
                    MacroNum = MacroNum + 1
                Case 3
                    '
                    g_hPopUpSubMenu(SubMNUItem) = CreatePopupMenu()
                    
                    g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_POPUP, _
                        g_hPopUpSubMenu(SubMNUItem), .Cells(2 + RowNum, 2))
                    SubMNUItem = SubMNUItem + 1
                 Case 4
                    '
                    '
                    '
                    g_Rt(TopMNU) = AppendMenu(g_hPopUpSubMenu(SubMNUItem - 1), _
                        MF_STRING, IDM_MU + .Cells(2 + RowNum, 5), .Cells(2 + RowNum, 2))
                    '
                    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 "Erro nº:=" & Err.Number & vbCrLf & _
            "Descrição:=" & Err.Description & vbCrLf & _
            "Verifique os nomes das Macros!", vbCritical + vbMsgBoxHelpButton, _
            "Erro na Macro Menu", 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

Excel File
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Sort by date Sort by votes
You must log in or register to reply here.

Similar threads

S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
721
Jaafar Tribak
Jaafar Tribak
M
  • Question Question
Menu bar 64bit code error
Replies
2
Views
1K
MDYusuf
M
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
861
Jaafar Tribak
Jaafar Tribak
G
  • Solved
Getting code to work in 64 Bit Excel
Replies
5
Views
1K
Gborden800
G
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
787
huiettcm
H

Forum statistics

Threads
1,224,823
Messages
6,181,170
Members
453,021
Latest member
Justyna P

Share this page

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
Back
Top