Membuat menu pada userform excel macro

Banyak komentar tentang bagaimana membuat menu pada userform dengan macro excel di aplikasikeuanganaja.blogspot.co.id, saya mencoba memposting ulang tentang bagaimana cara membuat menu pada userform excel.

Userform selain untuk menampilkan data melalui tool box, juga bisa dipakai untuk menampilkan menu agar tampilan menu tidak dibuat berderet pada userform itu sendiri, kalau pada blog mirip menu horizontal.sehingga penampilan dari userform itu lebih interaktif dan bisa dibuat seperti aplikasi-aplikasi lainnya seperti pada web ataupun aplikasi seperti visual basic.

Ok langsung saja saya berikan tips membuat menu pada userform dengan menggunakan macro excel.berikut langkah-langkahnya :

Bukalah file excel. kemudian bukalah jendela visual basic pada menu developer atau dengan menekan Alt + F11 pada keyboad.
Kemudian pilih menu insert Module lalu copykan kode berikut :

Option Explicit
Option Base 1
' membuat Windows Menu dengan menggunakan API
'--------------------------------------------

' Membuat horizontal menu bar di bagian atas
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 ' Menu Item ID
'//
Public g_hPopUpMenu() As Long       ' Popupmenu handles
Public g_hMenu As Long              ' Userform menu handle
Public g_hPopUpSubMenu() As Long    ' Submenu handles
Public g_Rt() As Long               ' Values for testing debuging
Public g_APIMacro() As String       ' Routine names associated with Menus
Public g_hForm As Long              ' Userform handle
Public g_MNUSheet As Worksheet      ' Menu Sheet

Public Sub CreateAPIMenu()
' sub ini harusnya terekseusi jika terjadi init Userform
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")
    SubMNU = .Range("B1")

    ReDim g_hPopUpMenu(TopMNUitems)
    ReDim g_Rt(TopMNUitems)
    ReDim g_hPopUpSubMenu(SubMNU)
    ReDim g_APIMacro(.Range("C1").Value)

    ' Main Menu Area at top
    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
        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 = "END"
            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))
                    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 "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

Setelah itu buatlah module dengan cara insert module, pada modul yang kedua ini ketikan script berikut :

Option Explicit

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

    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

Untuk module yang ketiga ketikan kode berikut

Option Explicit

Sub Loader()

    #If VBA6 Then
        frmTask.show
    #Else
        Sorry
    #End If

End Sub

Sub Sorry()
    Dim Msg As String

    Msg = "Sorry .... dosen't run on Versions <2000 font=" ">
    MsgBox Msg, vbExclamation
    'Application.UserControl = False
    'Application.IgnoreRemoteRequests = True
End Sub

Kemudian pada modul yang ke empat ketikan kode berikut :

Sub test()
MsgBox "Percobaan Menu"
End Sub

untuk langkah selanjutnya kita membuat objek userform sebagai media untuk meletakan menu , cara untuk membuat userform dengan mengklik menu insert pada jendela visual basic kemudian pilih userform. pada jendela properties ganti name userform dengan frmTask. kemudian double klik userform itu sehingga muncul jendel untuk menuliskan kode maka setelah itu ketikan atau copy kode berikut :

Option Explicit

Private Sub UserForm_Initialize()

    'UserForm Handle
    g_hForm = FindWindow(vbNullString, Me.Caption)

    Call CreateAPIMenu

    With Me
        .Height = 200 '250 - 45
        .Height = 253 'Original + 19
    End With

    g_lpMyWndProc = SetWindowLong(g_hForm, GWL_WNDPROC, AddressOf HookWinProc)

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