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 :
- Setelah itu buatlah module dengan cara insert module, pada modul yang kedua ini ketikan script berikut :
- Untuk module yang ketiga ketikan kode berikut
- Kemudian pada modul yang ke empat ketikan kode berikut :
- 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 :
- semua langkah tersebut belum bisa dijalankan apabila dalam sheet excelnya belum di atur pada module pertama ada tulisan
| 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 |
| 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 |
| 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 |
| Sub test() MsgBox "Percobaan Menu" End Sub |
| 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 |
- ' Set menusheet
Set g_MNUSheet = ThisWorkbook.Sheets("APIMNU")
