- Tham gia
- 30/5/06
- Bài viết
- 1,798
- Được thích
- 4,705
- Giới tính
- Nam
Chào các bạn,
Đối với các bạn lập trình chuyên nghiệp thì topic này xin bỏ qua.
Như đã có lần tôi giới thiệu với các bạn một ví dụ nhỏ về việc tạo Menu trong userForm trong VBA.
Nay tình cờ tôi tìm được một file ví dụ, các bạn có thể dễ dàng nghiên cứu.
Việc tạo menu cũng áp dụng kỹ thuật Table Driver mà nhiều chuyên gia về VBA sử dụng.
Đoạn code trong form chính như sau:
Phần chủ yếu của kỹ thuật này nằm ở hai module
basAPIMNU và basAPIMNU_Hook
Module basAPIMNU:
Lê Văn Duyệt
Đối với các bạn lập trình chuyên nghiệp thì topic này xin bỏ qua.
Như đã có lần tôi giới thiệu với các bạn một ví dụ nhỏ về việc tạo Menu trong userForm trong VBA.
Nay tình cờ tôi tìm được một file ví dụ, các bạn có thể dễ dàng nghiên cứu.
Việc tạo menu cũng áp dụng kỹ thuật Table Driver mà nhiều chuyên gia về VBA sử dụng.
Đoạn code trong form chính như sau:
Mã:
Option Explicit
'// UserForm
Private Sub UserForm_Initialize()
'// Get the UserForm Handle - lấy Handle của UserForm
g_hForm = FindWindow(vbNullString, Me.Caption)
'// Create our menu - Tạo Menu
Call CreateAPIMenu
'// Work around for Windows repaint
With Me
.Height = 200 ' 250 - 45
.Height = 253 ' Original + 19
End With
'// Subclass The Userform - Subclass UserForm
'Các bạn cần phải tìm hiểu kỹ thuật Subclass
'Như đã có lần anh smbsolutions và Tuân đã có đề cập
'http://www.giaiphapexcel.com/forum/showthread.php?t=1071&page=4
g_lpMyWndProc = SetWindowLong(g_hForm, GWL_WNDPROC, AddressOf HookWinProc)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'// Clean up - Xóa Menu và trả lại handle
DestroyMenu g_hMenu
SetWindowLong g_hForm, GWL_WNDPROC, g_lpMyWndProc
End Sub
Private Sub UserForm_Terminate()
'// Safety Clean up - Tương tự như ở thủ tục sự kiện QueryClose
DestroyMenu g_hMenu
SetWindowLong g_hForm, GWL_WNDPROC, g_lpMyWndProc
End SubPhần chủ yếu của kỹ thuật này nằm ở hai module
basAPIMNU và basAPIMNU_Hook
Module basAPIMNU:
Mã:
Option Explicit
Option Base 1
'---------------------------------------------------------------------------------------
' Module : basMenuAPIMNU
' DateTime : 05/01/05 14:33
' Author : Ivan F Moala
' Site : http://www.xcelfiles.com
' Purpose : Creates Windows Menu using API's
'---------------------------------------------------------------------------------------
'// Creates a horizontal menu bar @ the top, suitable for attaching to a top-level window.
'// eg [File], [Edit] etc and usually ending in Help
'// That's the Basic Format.. with [Windows] usually 2nd to last.
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 '// Our Menu Item ID
'//
Public g_hPopUpMenu() As Long '// Holds Popupmenu handles
Public g_hMenu As Long '// Userform menu handle
Public g_hPopUpSubMenu() As Long '// Holds Submenu handles
Public g_Rt() As Long '// Holds return Values for testing debuging
Public g_APIMacro() As String '// Holds Routine names associated with Menus
Public g_hForm As Long '// Userform handle
Public g_MNUSheet As Worksheet '// Menu Sheet
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 menusheet
Set g_MNUSheet = ThisWorkbook.Sheets("APIMNU")
With g_MNUSheet
'// Set-up now
TopMNUitems = .Range("A1") '// Number of Top Level
SubMNU = .Range("B1") '// Number of Sub Menus
ReDim g_hPopUpMenu(TopMNUitems) '//
ReDim g_Rt(TopMNUitems) '//
ReDim g_hPopUpSubMenu(SubMNU) '//
ReDim g_APIMacro(.Range("C1").Value) '//
'// 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)
For TopMNU = 1 To TopMNUitems
RowNum = RowNum + 1
'// AppendMenu(g_hMenu, MF_POPUP, hPopUpMenu1, "&File")
'// Create our Top Menu
g_hPopUpMenu(TopMNU) = CreatePopupMenu()
'// For 1st Menu Index is (2 + RowNum) after which it is (1 + RowNum)
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 we get to the END of the Menu = New TOP LEVEL MENU Starts!
Do Until .Cells(2 + RowNum, 4).Text = "END"
Select Case .Cells(2 + RowNum, 1).Value
Case 1
'// Do nothing for Testing
Case 0
'// Menu Seperator/Divider ... IDM_MU + Cells(2 + RowNum, 5)
'// AppendMenu(hPopUpMenu1, MF_SEPARATOR, IDM_MU + num, vbNullString)
'// If it is within Submenu to a Submenu then....
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
'// STD Sub
'// AppendMenu(hPopUpMenu1, MF_STRING, IDM_MU + num, " &New task (Run...)")
g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_STRING, _
IDM_MU + .Cells(2 + RowNum, 5), .Cells(2 + RowNum, 2))
'// Update our Routine to Run here
g_APIMacro(MacroNum) = .Cells(2 + RowNum, 3).Text
MacroNum = MacroNum + 1
Case 3
'// A SUBMENU Caption = 3
g_hPopUpSubMenu(SubMNUItem) = CreatePopupMenu()
'// AppendMenu(g_hMenu, MF_POPUP, hPopUpSubMenu1, vbNullString)
g_Rt(TopMNU) = AppendMenu(g_hPopUpMenu(TopMNU), MF_POPUP, _
g_hPopUpSubMenu(SubMNUItem), .Cells(2 + RowNum, 2))
SubMNUItem = SubMNUItem + 1
Case 4
'// A SUBMENUITEM = 4
'// AppendMenu(hPopUpSubMenu1, MF_STRING, IDM_MU + num, "SubMNU &1")
'// OK, lets build our sub Menu
g_Rt(TopMNU) = AppendMenu(g_hPopUpSubMenu(SubMNUItem - 1), _
MF_STRING, IDM_MU + .Cells(2 + RowNum, 5), .Cells(2 + RowNum, 2))
'// Update our Routine to Run here
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 SubLê Văn Duyệt
