Kính gửi: các Anh, Chị!
Xuất phát từ nhu cầu cá nhân và từ bài sau:
Đổi màu chữ trong menu chuột phải
Tôi có tìm hiểu và thấy việc tùy biến popup menu hoàn toàn thực hiện được.
Link tham khảo
và có thể áp dụng với VBA + API windows trong excel.
Tôi đã thực hiện được việc đổi size, font, màu text, back trong menu, và sẽ chia sẻ ở phần dưới. Hiện tôi có 01 câu hỏi như sau, rất mong nhận được sự trả lời từ các Anh, Chị:
- Làm cách nào để lấy được handle của popup menu chuột phải "nguyên bản" trên sheet của excel.
(Tôi đã thử với với các Class Name của menu: NetUIHWWND; các ClassName của cửa sổ cha: Net UI Tool Window; XLMAIN; nhưng không ra kết quả. Tôi đang dùng Ex2007, Win7 32bit)
Chia sẻ phương pháp tùy biến Menu chuột phải:
Với vướng mắc ở trên nên tôi không tùy biến với Menu nguyên bản của excel, mà tiến hành tự tạo một Popup Menu bằng hàm API để thay thế.
Phương pháp:
- Tự tạo Popup Menu với các Item theo nhu cầu (ưu điểm là mình nắm bắt được Handle của nó).
- Sử dụng kỹ thuật SubClass (hoặc Hook) để bẫy các thông điệp cho phép chỉnh sửa Menu.
- Bẫy các thông điệp và chỉnh sửa font, size, tô màu cho Menu theo mong muốn.
Thực hiện:
Khai báo các hàm API, biến:
[gpecode=vb]
'Khai bao ham API can su dung
'-------------------
'SubClass
Public Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" (ByVal hwnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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
'---------------------
'Lay Handle cac window
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'---------------------
'Ham lam viec voi Menu
'Tao Menu Popup
Public Declare Function CreatePopupMenu Lib "user32" () As Long
'Tao Item cho Menu
Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuW" _
(ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Long) As Long
'Huy Menu
Public Declare Function DestroyMenu Lib "user32.dll" (ByVal hMenu As Long) As Long
'Lay thong tin theo cau truc MENUITEMINFO tu Menu
Public Declare Function GetMenuItemInfo Lib "user32" _
Alias "GetMenuItemInfoA" _
(ByVal hMenu As Long, ByVal un As Long, _
ByVal b As Boolean, lpmii As MENUITEMINFO) As Long
'Cai dat cac thong tin cho Menu theo cau truc MENUITEMINFO
Public Declare Function SetMenuItemInfo Lib "user32" _
Alias "SetMenuItemInfoA" _
(ByVal hMenu As Long, ByVal uItem As Long, _
ByVal fByPosition As Long, lpmii As MENUITEMINFO) As Long
'Hien thi Menu Popup
Public Declare Function TrackPopupMenu Lib "user32" _
(ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, _
ByVal nReserved As Long, ByVal hwnd As Long, ByVal lprc As Any) As Long
'---------------------
'Ham tao font
Public Declare Function CreateFont Lib "gdi32" _
Alias "CreateFontA" (ByVal H As Long, _
ByVal W As Long, ByVal E As Long, ByVal O As Long, _
ByVal W As Long, ByVal i As Long, ByVal U As Long, _
ByVal S As Long, ByVal C As Long, ByVal OP As Long, _
ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, _
ByVal F As String) As Long
'---------------------
'Ham lam xu ly chuoi
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
ByVal lpString As String, ByVal nCount As Long) As Long
Public Declare Function ExtTextOut Lib "gdi32" Alias _
"ExtTextOutA" (ByVal hdc As Long, ByVal x As _
Long, ByVal y As Long, ByVal wOptions As Long, _
lpRect As RECT, ByVal lpString As String, _
ByVal nCount As Long, lpDx As Long) As Long
Public Declare Function GetTextExtentPoint Lib "gdi32" _
Alias "GetTextExtentPointA" (ByVal hdc As Long, _
ByVal lpszString As String, ByVal cbString As Long, _
lpSize As size) As Long
'Thiet lap mau cho chuoi
Public Declare Function SetTextColor Lib "gdi32" _
(ByVal hdc As Long, ByVal crColor As Long) As Long
'Thiet lap mau cho nen
Public Declare Function SetBkColor Lib "gdi32" _
(ByVal hdc As Long, ByVal crColor As Long) As Long
'---------------------
'Ham lam viec voi hande context, de xu ly do hoa
Public Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
'Ham ho tro khac
'---------------------
Public Declare Sub MemCopy Lib "kernel32" Alias _
"RtlMoveMemory" (dest As Any, src As Any, _
ByVal numbytes As Long)
Public Declare Function GetSysColor Lib "user32" _
(ByVal nIndex As Long) As Long
'Ham lay vi tri con tro chuot
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'---------------------
'Khai bao bien
'Bien luu thong tin Menu
Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Bien luu thong tin tu thong diep WM_DRAWITEM
Type DRAWITEMSTRUCT
CtlType As Long
CtlID As Long
itemID As Long
itemAction As Long
itemState As Long
hwndItem As Long
hdc As Long
rcItem As RECT
itemData As Long
End Type
' Bien luu thong tin kich thuoc menu
Type MEASUREITEMSTRUCT
CtlType As Long
CtlID As Long
itemID As Long
itemWidth As Long
itemHeight As Long
itemData As Long
End Type
'Bien luu thong tin tuy bien ve Font cho menu
Type myItemType
hFont As Long
cchItemText As Integer
szItemText As String * 32
End Type
'Bien luu thong tin toa do con tro chuot
Type POINTAPI
x As Long
y As Long
End Type
'Bien luu kich thuoc Menu
Type size
cx As Long
cy As Long
End Type
'Thong so cho ham Call Back
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
'IDItem cua Menu
Public Const MF_APPEND As Long = &H100&
Public Const MF_BITMAP As Long = &H4&
Public Const MF_BYCOMMAND As Long = &H0&
Public Const MF_BYPOSITION As Long = &H400&
Public Const MF_CALLBACKS As Long = &H8000000
Public Const MF_CHANGE As Long = &H80&
Public Const MF_CHECKED As Long = &H8&
Public Const MF_CONV As Long = &H40000000
Public Const MF_DEFAULT As Long = &H1000&
Public Const MF_DELETE As Long = &H200&
Public Const MF_DISABLED As Long = &H2&
Public Const MF_DLL_NAME As String = "Microsoft Picture Converter"
Public Const MF_ENABLED As Long = &H0&
Public Const MF_END As Long = &H80
Public Const MF_ERRORS As Long = &H10000000
Public Const MF_FLAGS_CREATE_BUT_NO_SHOW_DISABLED As Long = &H8
Public Const MF_FLAGS_FILL_IN_UNKNOWN_RESOURCE As Long = &H4
Public Const MF_FLAGS_EVEN_IF_NO_RESOURCE As Long = &H1
Public Const MF_FLAGS_NO_CREATE_IF_NO_RESOURCE As Long = &H2
Public Const MF_FPCR_FUNC As Long = &H25
Public Const MF_FPCR_FUNC_STR As String = "mf_fpcr"
Public Const MF_GRAYED As Long = &H1&
Public Const MF_HELP As Long = &H4000&
Public Const MF_HSZ_INFO As Long = &H1000000
Public Const MF_INSERT As Long = &H0&
Public Const MF_LINKS As Long = &H20000000
Public Const MF_MASK As Long = &HFF000000
Public Const MF_MENUBARBREAK As Long = &H20&
Public Const MF_MENUBREAK As Long = &H40&
Public Const MF_MOUSESELECT As Long = &H8000&
Public Const MF_OWNERDRAW As Long = &H100&
Public Const MF_POPUP As Long = &H10&
Public Const MF_POSTMSGS As Long = &H4000000
Public Const MF_REMOVE As Long = &H1000&
Public Const MF_RIGHTJUSTIFY As Long = &H4000&
Public Const MF_SENDMSGS As Long = &H2000000
Public Const MF_SEPARATOR As Long = &H800&
Public Const MF_STRING As Long = &H0&
Public Const MF_SYSMENU As Long = &H2000&
Public Const MF_UNCHECKED As Long = &H0&
Public Const MF_UNHILITE As Long = &H0&
Public Const MF_USECHECKBITMAPS As Long = &H200&
'IDItem cua SubMenu
Public Const MFT_BITMAP As Long = MF_BITMAP
Public Const MFT_MENUBARBREAK As Long = MF_MENUBARBREAK
Public Const MFT_MENUBREAK As Long = MF_MENUBREAK
Public Const MFT_OWNERDRAW As Long = MF_OWNERDRAW
Public Const MFT_RADIOCHECK As Long = &H200&
Public Const MFT_RIGHTJUSTIFY As Long = MF_RIGHTJUSTIFY
Public Const MFT_RIGHTORDER As Long = &H2000&
Public Const MFT_SEPARATOR As Long = MF_SEPARATOR
Public Const MFT_STRING As Long = MF_STRING
'MENUITEMINFO
Public Const MIIM_BITMAP As Long = &H80
Public Const MIIM_CHECKMARKS As Long = &H8
Public Const MIIM_DATA As Long = &H20
Public Const MIIM_FTYPE As Long = &H100
Public Const MIIM_ID As Long = &H2
Public Const MIIM_STATE As Long = &H1
Public Const MIIM_STRING As Long = &H40
Public Const MIIM_SUBMENU As Long = &H4
Public Const MIIM_TYPE As Long = &H10
'Thong so tu thiet lap cho cac style cua chuoi.
'Public Const IDM_CHARACTER = 10
Public Const IDM_REGULAR = 10
Public Const IDM_BOLD = 11
Public Const IDM_ITALIC = 12
Public Const IDM_UNDERLINE = 13
Public Const IDM_STRIKETHROUGH = 14
'Thong diep Window Message:
'Thong diep chuot
Public Const WM_LBUTTONDBLCLK As Long = &H203
Public Const WM_LBUTTONDOWN As Long = &H201
Public Const WM_LBUTTONUP As Long = &H202
Public Const WM_MBUTTONDBLCLK As Long = &H209
Public Const WM_MBUTTONDOWN As Long = &H207
Public Const WM_MBUTTONUP As Long = &H208
Public Const WM_RBUTTONDBLCLK As Long = &H206
Public Const WM_RBUTTONDOWN As Long = &H204
Public Const WM_RBUTTONUP As Long = &H205
'Thong diep hien thi Menu
Public Const WM_DRAWITEM = &H2B
Public Const WM_MEASUREITEM = &H2C
'Bien mau he thong
Public Const COLOR_MENU = 4
Public Const COLOR_MENUTEXT = 7
Public Const COLOR_HIGHLIGHT = 13
Public Const COLOR_HIGHLIGHTTEXT = 1
'Bien khac
Public Const ODS_SELECTED As Long = &H1
Public Const TPM_RETURNCMD = &H100&
'textout style
Public Const ETO_OPAQUE = 2
[/gpecode]
Hàm, thủ tục tạo Thiết lập Item cho Menu (tùy biến theo nhu cầu)
[gpecode=vb]
'Bien cac thuoc tinh Menu
Type ItemMenu
id As Long
caption As Long
size As Long
type As Long
style As Long
font As String
onAction As String
ColorText As Long
ColorBack As Long
ColorTextHightLight As Long
ColorTextBackHightLight As Long
End Type
Public iTemArr(5) As ItemMenu
Sub SetUpItemMenu()
'ReDim iTemArr(0 To 4) As myItemType
With iTemArr(0)
.id = 0: .size = 30: .type = MF_STRING: .caption = StrPtr("Regular")
.onAction =
.style = IDM_REGULAR: .font = "Arial"
.ColorText = vbRed: .ColorBack = vbWhite
.ColorTextHightLight = vbBlue: .ColorTextBackHightLight = vbBlack
End With
With iTemArr(1)
.id = 1: .size = 40: .type = MF_STRING: .caption = StrPtr("Bold")
.onAction = .style = IDM_BOLD: .font = "Symbol"
.ColorText = vbBlue: .ColorBack = vbCyan
.ColorTextHightLight = vbBlue: .ColorTextBackHightLight = vbRed
End With
With iTemArr(2)
.id = 2: .size = 50: .type = MF_STRING: .caption = StrPtr("Italic")
.onAction = .style = IDM_ITALIC: .font = "SansSerif"
.ColorText = vbYellow: .ColorBack = vbGreen
.ColorTextHightLight = vbWhite: .ColorTextBackHightLight = vbRed
End With
With iTemArr(3)
.id = 3: .size = 60: .type = MF_STRING: .caption = StrPtr("Underline")
.onAction = .style = IDM_UNDERLINE: .font = "System"
.ColorText = vbRed: .ColorBack = vbGreen
.ColorTextHightLight = vbGreen: .ColorTextBackHightLight = vbRed
End With
With iTemArr(4)
.id = 4: .size = 70: .type = MF_STRING: .caption = StrPtr("Strikethough")
.onAction = .style = IDM_STRIKETHROUGH: .font = "Times New Roman"
.ColorText = vbYellow: .ColorBack = vbBlue
.ColorTextHightLight = vbCyan: .ColorTextBackHightLight = vbWhite
End With
End Sub
[/gpecode]
Hàm, thủ tục tạo Popup Menu
[gpecode=vb]
'Khai bao bien dung chung
Public mnuItemCount, hMenu, MyItem() As myItemType
Public clrPrevText, clrPrevBkgnd
Public hfntPrev
Global Disable_System_Menu As Boolean
Sub Create_Menu()
Dim minfo As MENUITEMINFO
Dim r As Long, id As Integer
'Tao menu Popup (dang la menu trong)
hMenu = CreatePopupMenu()
'Tao Item Menu
SetUpItemMenu
'Tao mot vai Item menu
For id = 0 To UBound(iTemArr) - 1
AppendMenu hMenu, iTemArr(id).type, iTemArr(id).style, iTemArr(id).caption
Next id
'Khoi tao bien luu thong tin Font de tuy bien cho Menu
ReDim MyItem(0 To UBound(iTemArr) - 1) As myItemType
For id = 0 To UBound(iTemArr) - 1
'Khai bao bien de luu thong tin MENUITEMINFO
minfo.cbSize = Len(minfo)
minfo.fMask = MIIM_TYPE
minfo.fType = MFT_STRING
minfo.dwTypeData = Space$(256)
minfo.cch = Len(minfo.dwTypeData)
'Lay thong tin MENUITEMINFO tu Menu
r = GetMenuItemInfo(hMenu, id, True, minfo)
'Luu cac thong tin can thiet vao mang bien tuy bien cho Menu
MyItem(id).cchItemText = minfo.cch 'menuitem length
MyItem(id).szItemText = Trim(minfo.dwTypeData) 'text
MyItem(id).hFont = CreateMenuItemFont(iTemArr(id).size, iTemArr(id).style, iTemArr(id).font) 'font
'Thay doi loai Menu - Cho phep nguoi dung co the thay doi.
'Chi khi co thiet lap, he thong moi cho phat sinh thong diep WM_DRAWITEM va WM_MEASUREITEM
minfo.fType = MFT_OWNERDRAW
minfo.fMask = MIIM_TYPE Or MIIM_DATA
minfo.dwItemData = id
'Thiet lap cac thong so va item Menu
r = SetMenuItemInfo(hMenu, id, True, minfo)
Next id
End Sub
'Hien thi Menu
Sub Display_Menu()
Dim MP As POINTAPI
Dim sMenu As Long
'hwndP = FindWindow("XLMAIN", Application.Caption)
'Lay toa do chuot de hien thi popup Menu tai vi tri chuot
GetCursorPos MP
'TPM_RETURNCMD cho phep tra ve gia tri IDCommand, luu vao bien sMenu
sMenu = TrackPopupMenu(hMenu, TPM_RETURNCMD, MP.x, MP.y, 0, Application.hwnd, 0&)
'Xu ly cac lenh tu Menu
Select Case sMenu
Case IDM_REGULAR
MsgBox "Regular"
Case IDM_BOLD
MsgBox "Bold"
Case IDM_ITALIC
MsgBox "Italic"
Case IDM_UNDERLINE
MsgBox "Underline"
Case IDM_STRIKETHROUGH
MsgBox "Strikethrough"
Case Else
End Select
End Sub
'Tao Font tuy bien de su dung cho Item Menu
Function CreateMenuItemFont(uSize As Long, uStyle As Long, uFontName As String) As Long
Dim Weight As Long
Dim use_italic As Long
Dim use_underline As Long
Dim use_strikethrough As Long
Select Case uStyle
Case IDM_BOLD
Weight = 700
Case IDM_ITALIC
use_italic = True
Case IDM_UNDERLINE
use_underline = True
Case IDM_STRIKETHROUGH
use_strikethrough = True
Case Else
End Select
CreateMenuItemFont = CreateFont(uSize, 0, _
0, 0, Weight, _
use_italic, use_underline, _
use_strikethrough, 136, 0, _
16, 0, 0, uFontName)
End Function
'Thu tuc xu ly tuy bien Item Menu trong thong diep WM_DRAWITEM
Sub OnDrawMenuItem(lpdis As DRAWITEMSTRUCT)
Dim x, y
Dim id
id = lpdis.itemData
'set the menuitem colors
If (lpdis.itemState And ODS_SELECTED) Then 'if selected
clrPrevText = SetTextColor(lpdis.hdc, iTemArr(id).ColorTextHightLight) 'GetSysColor(COLOR_HIGHLIGHTTEXT))
clrPrevBkgnd = SetBkColor(lpdis.hdc, iTemArr(id).ColorTextBackHightLight) 'GetSysColor(COLOR_HIGHLIGHT))
Else
clrPrevText = SetTextColor(lpdis.hdc, iTemArr(id).ColorText) 'GetSysColor(COLOR_MENUTEXT))
clrPrevBkgnd = SetBkColor(lpdis.hdc, iTemArr(id).ColorBack) 'GetSysColor(COLOR_MENU))
End If
'leave space for checkmark
'may use GetMenuCheckMarkDimensions
x = lpdis.rcItem.Left + 20 '20 la khoang cach thut dau dong cua MenuItem
y = lpdis.rcItem.Top
hfntPrev = SelectObject(lpdis.hdc, MyItem(id).hFont)
ExtTextOut lpdis.hdc, x, y, ETO_OPAQUE, _
lpdis.rcItem, Trim(" "), 1&, 0&
TextOut lpdis.hdc, x, y, MyItem(id).szItemText, MyItem(id).cchItemText
'may put some bitblt function here also.
SetTextColor lpdis.hdc, clrPrevText
SetBkColor lpdis.hdc, clrPrevBkgnd
SelectObject lpdis.hdc, hfntPrev
End Sub
'Thu tuc xu ly kich thuoc Menu phu hop voi tung Item, trong thong diep WM_MEASUREITEM
Function OnMeasureItem(hwnd As Long, lpmis As MEASUREITEMSTRUCT) As MEASUREITEMSTRUCT
Dim xM As MEASUREITEMSTRUCT, hfntOld As Long
Dim S As size, hdc As Long
'find DC
hdc = GetDC(hwnd)
hfntOld = SelectObject(hdc, MyItem(lpmis.itemData).hFont)
GetTextExtentPoint hdc, MyItem(lpmis.itemData).szItemText, _
MyItem(lpmis.itemData).cchItemText, S
'set menu item rect
xM.itemWidth = S.cx + 11
xM.itemHeight = S.cy
SelectObject hdc, hfntOld
ReleaseDC hwnd, hdc
LSet OnMeasureItem = xM
End Function
[/gpecode]
Thủ tục, Hàm theo phương pháp SubClass để bẫy thông điệp.
[gpecode=vb]
'Khai bao bien chung
Public OldWindowProc
Public Sub SubClass_Sheet()
'hwndP = FindWindow("XLMAIN", Application.Caption)
OldWindowProc = SetWindowLong(Application.hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
End Sub
Public Sub Disable_SubClass()
'hwndP = FindWindow("XLMAIN", Application.Caption)
Disable_System_Menu = False
DestroyMenu hMenu
SetWindowLong Application.hwnd, GWL_WNDPROC, OldWindowProc
End Sub
'Ham CallBack
Public Function NewWindowProc(ByVal hwnd As Long, _
ByVal msg As Long, ByVal wparam As Long, _
lparam As Long) As Long
Dim dM As DRAWITEMSTRUCT
Dim mM As MEASUREITEMSTRUCT
Select Case msg
'Xu ly thong diep he thong ve Menu
Case WM_DRAWITEM
MemCopy dM, lparam, Len(dM)
OnDrawMenuItem dM
'Xu ly thong diep kich thuoc Menu
Case WM_MEASUREITEM
MemCopy mM, lparam, Len(mM)
mM = OnMeasureItem(hwnd, mM)
MemCopy lparam, mM, Len(mM)
'Co the bo sung de xu ly cac thong diep khac neu muon
Case WM_COMMAND
'Co the xu ly lenh Menu o day
Case Else
End Select
'Tra ve he thong tu xu ly cac thong diep con lai
NewWindowProc = CallWindowProc(OldWindowProc, _
hwnd, msg, wparam, VarPtr(lparam))
End Function
[/gpecode]
Ví dụ ta tùy biến với menu chuột phải tại Sheet1, ta tạo 1 nút lệnh để bật tắt Menu, chèn code sau vào sheet1
[gpecode=vb]
Private Sub CommandButton1_Click()
If CommandButton1.caption = "Start" Then
Disable_System_Menu = True
Create_Menu
SubClass_Sheet
CommandButton1.caption = "Stop"
Else
Disable_SubClass
CommandButton1.caption = "Start"
End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = Disable_System_Menu
If Cancel = True Then Display_Menu
End Sub
[/gpecode]
(Mọi người tham khảo thêm theo file đính kèm)
Xuất phát từ nhu cầu cá nhân và từ bài sau:
Đổi màu chữ trong menu chuột phải
Tôi có tìm hiểu và thấy việc tùy biến popup menu hoàn toàn thực hiện được.
Link tham khảo
và có thể áp dụng với VBA + API windows trong excel.
Tôi đã thực hiện được việc đổi size, font, màu text, back trong menu, và sẽ chia sẻ ở phần dưới. Hiện tôi có 01 câu hỏi như sau, rất mong nhận được sự trả lời từ các Anh, Chị:
- Làm cách nào để lấy được handle của popup menu chuột phải "nguyên bản" trên sheet của excel.
(Tôi đã thử với với các Class Name của menu: NetUIHWWND; các ClassName của cửa sổ cha: Net UI Tool Window; XLMAIN; nhưng không ra kết quả. Tôi đang dùng Ex2007, Win7 32bit)
Chia sẻ phương pháp tùy biến Menu chuột phải:
Với vướng mắc ở trên nên tôi không tùy biến với Menu nguyên bản của excel, mà tiến hành tự tạo một Popup Menu bằng hàm API để thay thế.
Phương pháp:
- Tự tạo Popup Menu với các Item theo nhu cầu (ưu điểm là mình nắm bắt được Handle của nó).
- Sử dụng kỹ thuật SubClass (hoặc Hook) để bẫy các thông điệp cho phép chỉnh sửa Menu.
- Bẫy các thông điệp và chỉnh sửa font, size, tô màu cho Menu theo mong muốn.
Thực hiện:
Khai báo các hàm API, biến:
[gpecode=vb]
'Khai bao ham API can su dung
'-------------------
'SubClass
Public Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" (ByVal hwnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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
'---------------------
'Lay Handle cac window
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'---------------------
'Ham lam viec voi Menu
'Tao Menu Popup
Public Declare Function CreatePopupMenu Lib "user32" () As Long
'Tao Item cho Menu
Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuW" _
(ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Long) As Long
'Huy Menu
Public Declare Function DestroyMenu Lib "user32.dll" (ByVal hMenu As Long) As Long
'Lay thong tin theo cau truc MENUITEMINFO tu Menu
Public Declare Function GetMenuItemInfo Lib "user32" _
Alias "GetMenuItemInfoA" _
(ByVal hMenu As Long, ByVal un As Long, _
ByVal b As Boolean, lpmii As MENUITEMINFO) As Long
'Cai dat cac thong tin cho Menu theo cau truc MENUITEMINFO
Public Declare Function SetMenuItemInfo Lib "user32" _
Alias "SetMenuItemInfoA" _
(ByVal hMenu As Long, ByVal uItem As Long, _
ByVal fByPosition As Long, lpmii As MENUITEMINFO) As Long
'Hien thi Menu Popup
Public Declare Function TrackPopupMenu Lib "user32" _
(ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, _
ByVal nReserved As Long, ByVal hwnd As Long, ByVal lprc As Any) As Long
'---------------------
'Ham tao font
Public Declare Function CreateFont Lib "gdi32" _
Alias "CreateFontA" (ByVal H As Long, _
ByVal W As Long, ByVal E As Long, ByVal O As Long, _
ByVal W As Long, ByVal i As Long, ByVal U As Long, _
ByVal S As Long, ByVal C As Long, ByVal OP As Long, _
ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, _
ByVal F As String) As Long
'---------------------
'Ham lam xu ly chuoi
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
ByVal lpString As String, ByVal nCount As Long) As Long
Public Declare Function ExtTextOut Lib "gdi32" Alias _
"ExtTextOutA" (ByVal hdc As Long, ByVal x As _
Long, ByVal y As Long, ByVal wOptions As Long, _
lpRect As RECT, ByVal lpString As String, _
ByVal nCount As Long, lpDx As Long) As Long
Public Declare Function GetTextExtentPoint Lib "gdi32" _
Alias "GetTextExtentPointA" (ByVal hdc As Long, _
ByVal lpszString As String, ByVal cbString As Long, _
lpSize As size) As Long
'Thiet lap mau cho chuoi
Public Declare Function SetTextColor Lib "gdi32" _
(ByVal hdc As Long, ByVal crColor As Long) As Long
'Thiet lap mau cho nen
Public Declare Function SetBkColor Lib "gdi32" _
(ByVal hdc As Long, ByVal crColor As Long) As Long
'---------------------
'Ham lam viec voi hande context, de xu ly do hoa
Public Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
'Ham ho tro khac
'---------------------
Public Declare Sub MemCopy Lib "kernel32" Alias _
"RtlMoveMemory" (dest As Any, src As Any, _
ByVal numbytes As Long)
Public Declare Function GetSysColor Lib "user32" _
(ByVal nIndex As Long) As Long
'Ham lay vi tri con tro chuot
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'---------------------
'Khai bao bien
'Bien luu thong tin Menu
Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Bien luu thong tin tu thong diep WM_DRAWITEM
Type DRAWITEMSTRUCT
CtlType As Long
CtlID As Long
itemID As Long
itemAction As Long
itemState As Long
hwndItem As Long
hdc As Long
rcItem As RECT
itemData As Long
End Type
' Bien luu thong tin kich thuoc menu
Type MEASUREITEMSTRUCT
CtlType As Long
CtlID As Long
itemID As Long
itemWidth As Long
itemHeight As Long
itemData As Long
End Type
'Bien luu thong tin tuy bien ve Font cho menu
Type myItemType
hFont As Long
cchItemText As Integer
szItemText As String * 32
End Type
'Bien luu thong tin toa do con tro chuot
Type POINTAPI
x As Long
y As Long
End Type
'Bien luu kich thuoc Menu
Type size
cx As Long
cy As Long
End Type
'Thong so cho ham Call Back
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
'IDItem cua Menu
Public Const MF_APPEND As Long = &H100&
Public Const MF_BITMAP As Long = &H4&
Public Const MF_BYCOMMAND As Long = &H0&
Public Const MF_BYPOSITION As Long = &H400&
Public Const MF_CALLBACKS As Long = &H8000000
Public Const MF_CHANGE As Long = &H80&
Public Const MF_CHECKED As Long = &H8&
Public Const MF_CONV As Long = &H40000000
Public Const MF_DEFAULT As Long = &H1000&
Public Const MF_DELETE As Long = &H200&
Public Const MF_DISABLED As Long = &H2&
Public Const MF_DLL_NAME As String = "Microsoft Picture Converter"
Public Const MF_ENABLED As Long = &H0&
Public Const MF_END As Long = &H80
Public Const MF_ERRORS As Long = &H10000000
Public Const MF_FLAGS_CREATE_BUT_NO_SHOW_DISABLED As Long = &H8
Public Const MF_FLAGS_FILL_IN_UNKNOWN_RESOURCE As Long = &H4
Public Const MF_FLAGS_EVEN_IF_NO_RESOURCE As Long = &H1
Public Const MF_FLAGS_NO_CREATE_IF_NO_RESOURCE As Long = &H2
Public Const MF_FPCR_FUNC As Long = &H25
Public Const MF_FPCR_FUNC_STR As String = "mf_fpcr"
Public Const MF_GRAYED As Long = &H1&
Public Const MF_HELP As Long = &H4000&
Public Const MF_HSZ_INFO As Long = &H1000000
Public Const MF_INSERT As Long = &H0&
Public Const MF_LINKS As Long = &H20000000
Public Const MF_MASK As Long = &HFF000000
Public Const MF_MENUBARBREAK As Long = &H20&
Public Const MF_MENUBREAK As Long = &H40&
Public Const MF_MOUSESELECT As Long = &H8000&
Public Const MF_OWNERDRAW As Long = &H100&
Public Const MF_POPUP As Long = &H10&
Public Const MF_POSTMSGS As Long = &H4000000
Public Const MF_REMOVE As Long = &H1000&
Public Const MF_RIGHTJUSTIFY As Long = &H4000&
Public Const MF_SENDMSGS As Long = &H2000000
Public Const MF_SEPARATOR As Long = &H800&
Public Const MF_STRING As Long = &H0&
Public Const MF_SYSMENU As Long = &H2000&
Public Const MF_UNCHECKED As Long = &H0&
Public Const MF_UNHILITE As Long = &H0&
Public Const MF_USECHECKBITMAPS As Long = &H200&
'IDItem cua SubMenu
Public Const MFT_BITMAP As Long = MF_BITMAP
Public Const MFT_MENUBARBREAK As Long = MF_MENUBARBREAK
Public Const MFT_MENUBREAK As Long = MF_MENUBREAK
Public Const MFT_OWNERDRAW As Long = MF_OWNERDRAW
Public Const MFT_RADIOCHECK As Long = &H200&
Public Const MFT_RIGHTJUSTIFY As Long = MF_RIGHTJUSTIFY
Public Const MFT_RIGHTORDER As Long = &H2000&
Public Const MFT_SEPARATOR As Long = MF_SEPARATOR
Public Const MFT_STRING As Long = MF_STRING
'MENUITEMINFO
Public Const MIIM_BITMAP As Long = &H80
Public Const MIIM_CHECKMARKS As Long = &H8
Public Const MIIM_DATA As Long = &H20
Public Const MIIM_FTYPE As Long = &H100
Public Const MIIM_ID As Long = &H2
Public Const MIIM_STATE As Long = &H1
Public Const MIIM_STRING As Long = &H40
Public Const MIIM_SUBMENU As Long = &H4
Public Const MIIM_TYPE As Long = &H10
'Thong so tu thiet lap cho cac style cua chuoi.
'Public Const IDM_CHARACTER = 10
Public Const IDM_REGULAR = 10
Public Const IDM_BOLD = 11
Public Const IDM_ITALIC = 12
Public Const IDM_UNDERLINE = 13
Public Const IDM_STRIKETHROUGH = 14
'Thong diep Window Message:
'Thong diep chuot
Public Const WM_LBUTTONDBLCLK As Long = &H203
Public Const WM_LBUTTONDOWN As Long = &H201
Public Const WM_LBUTTONUP As Long = &H202
Public Const WM_MBUTTONDBLCLK As Long = &H209
Public Const WM_MBUTTONDOWN As Long = &H207
Public Const WM_MBUTTONUP As Long = &H208
Public Const WM_RBUTTONDBLCLK As Long = &H206
Public Const WM_RBUTTONDOWN As Long = &H204
Public Const WM_RBUTTONUP As Long = &H205
'Thong diep hien thi Menu
Public Const WM_DRAWITEM = &H2B
Public Const WM_MEASUREITEM = &H2C
'Bien mau he thong
Public Const COLOR_MENU = 4
Public Const COLOR_MENUTEXT = 7
Public Const COLOR_HIGHLIGHT = 13
Public Const COLOR_HIGHLIGHTTEXT = 1
'Bien khac
Public Const ODS_SELECTED As Long = &H1
Public Const TPM_RETURNCMD = &H100&
'textout style
Public Const ETO_OPAQUE = 2
[/gpecode]
Hàm, thủ tục tạo Thiết lập Item cho Menu (tùy biến theo nhu cầu)
[gpecode=vb]
'Bien cac thuoc tinh Menu
Type ItemMenu
id As Long
caption As Long
size As Long
type As Long
style As Long
font As String
onAction As String
ColorText As Long
ColorBack As Long
ColorTextHightLight As Long
ColorTextBackHightLight As Long
End Type
Public iTemArr(5) As ItemMenu
Sub SetUpItemMenu()
'ReDim iTemArr(0 To 4) As myItemType
With iTemArr(0)
.id = 0: .size = 30: .type = MF_STRING: .caption = StrPtr("Regular")
.onAction =
.style = IDM_REGULAR: .font = "Arial".ColorText = vbRed: .ColorBack = vbWhite
.ColorTextHightLight = vbBlue: .ColorTextBackHightLight = vbBlack
End With
With iTemArr(1)
.id = 1: .size = 40: .type = MF_STRING: .caption = StrPtr("Bold")
.onAction =
.style = IDM_BOLD: .font = "Symbol".ColorText = vbBlue: .ColorBack = vbCyan
.ColorTextHightLight = vbBlue: .ColorTextBackHightLight = vbRed
End With
With iTemArr(2)
.id = 2: .size = 50: .type = MF_STRING: .caption = StrPtr("Italic")
.onAction =
.style = IDM_ITALIC: .font = "SansSerif".ColorText = vbYellow: .ColorBack = vbGreen
.ColorTextHightLight = vbWhite: .ColorTextBackHightLight = vbRed
End With
With iTemArr(3)
.id = 3: .size = 60: .type = MF_STRING: .caption = StrPtr("Underline")
.onAction =
.style = IDM_UNDERLINE: .font = "System".ColorText = vbRed: .ColorBack = vbGreen
.ColorTextHightLight = vbGreen: .ColorTextBackHightLight = vbRed
End With
With iTemArr(4)
.id = 4: .size = 70: .type = MF_STRING: .caption = StrPtr("Strikethough")
.onAction =
.style = IDM_STRIKETHROUGH: .font = "Times New Roman".ColorText = vbYellow: .ColorBack = vbBlue
.ColorTextHightLight = vbCyan: .ColorTextBackHightLight = vbWhite
End With
End Sub
[/gpecode]
Hàm, thủ tục tạo Popup Menu
[gpecode=vb]
'Khai bao bien dung chung
Public mnuItemCount, hMenu, MyItem() As myItemType
Public clrPrevText, clrPrevBkgnd
Public hfntPrev
Global Disable_System_Menu As Boolean
Sub Create_Menu()
Dim minfo As MENUITEMINFO
Dim r As Long, id As Integer
'Tao menu Popup (dang la menu trong)
hMenu = CreatePopupMenu()
'Tao Item Menu
SetUpItemMenu
'Tao mot vai Item menu
For id = 0 To UBound(iTemArr) - 1
AppendMenu hMenu, iTemArr(id).type, iTemArr(id).style, iTemArr(id).caption
Next id
'Khoi tao bien luu thong tin Font de tuy bien cho Menu
ReDim MyItem(0 To UBound(iTemArr) - 1) As myItemType
For id = 0 To UBound(iTemArr) - 1
'Khai bao bien de luu thong tin MENUITEMINFO
minfo.cbSize = Len(minfo)
minfo.fMask = MIIM_TYPE
minfo.fType = MFT_STRING
minfo.dwTypeData = Space$(256)
minfo.cch = Len(minfo.dwTypeData)
'Lay thong tin MENUITEMINFO tu Menu
r = GetMenuItemInfo(hMenu, id, True, minfo)
'Luu cac thong tin can thiet vao mang bien tuy bien cho Menu
MyItem(id).cchItemText = minfo.cch 'menuitem length
MyItem(id).szItemText = Trim(minfo.dwTypeData) 'text
MyItem(id).hFont = CreateMenuItemFont(iTemArr(id).size, iTemArr(id).style, iTemArr(id).font) 'font
'Thay doi loai Menu - Cho phep nguoi dung co the thay doi.
'Chi khi co thiet lap, he thong moi cho phat sinh thong diep WM_DRAWITEM va WM_MEASUREITEM
minfo.fType = MFT_OWNERDRAW
minfo.fMask = MIIM_TYPE Or MIIM_DATA
minfo.dwItemData = id
'Thiet lap cac thong so va item Menu
r = SetMenuItemInfo(hMenu, id, True, minfo)
Next id
End Sub
'Hien thi Menu
Sub Display_Menu()
Dim MP As POINTAPI
Dim sMenu As Long
'hwndP = FindWindow("XLMAIN", Application.Caption)
'Lay toa do chuot de hien thi popup Menu tai vi tri chuot
GetCursorPos MP
'TPM_RETURNCMD cho phep tra ve gia tri IDCommand, luu vao bien sMenu
sMenu = TrackPopupMenu(hMenu, TPM_RETURNCMD, MP.x, MP.y, 0, Application.hwnd, 0&)
'Xu ly cac lenh tu Menu
Select Case sMenu
Case IDM_REGULAR
MsgBox "Regular"
Case IDM_BOLD
MsgBox "Bold"
Case IDM_ITALIC
MsgBox "Italic"
Case IDM_UNDERLINE
MsgBox "Underline"
Case IDM_STRIKETHROUGH
MsgBox "Strikethrough"
Case Else
End Select
End Sub
'Tao Font tuy bien de su dung cho Item Menu
Function CreateMenuItemFont(uSize As Long, uStyle As Long, uFontName As String) As Long
Dim Weight As Long
Dim use_italic As Long
Dim use_underline As Long
Dim use_strikethrough As Long
Select Case uStyle
Case IDM_BOLD
Weight = 700
Case IDM_ITALIC
use_italic = True
Case IDM_UNDERLINE
use_underline = True
Case IDM_STRIKETHROUGH
use_strikethrough = True
Case Else
End Select
CreateMenuItemFont = CreateFont(uSize, 0, _
0, 0, Weight, _
use_italic, use_underline, _
use_strikethrough, 136, 0, _
16, 0, 0, uFontName)
End Function
'Thu tuc xu ly tuy bien Item Menu trong thong diep WM_DRAWITEM
Sub OnDrawMenuItem(lpdis As DRAWITEMSTRUCT)
Dim x, y
Dim id
id = lpdis.itemData
'set the menuitem colors
If (lpdis.itemState And ODS_SELECTED) Then 'if selected
clrPrevText = SetTextColor(lpdis.hdc, iTemArr(id).ColorTextHightLight) 'GetSysColor(COLOR_HIGHLIGHTTEXT))
clrPrevBkgnd = SetBkColor(lpdis.hdc, iTemArr(id).ColorTextBackHightLight) 'GetSysColor(COLOR_HIGHLIGHT))
Else
clrPrevText = SetTextColor(lpdis.hdc, iTemArr(id).ColorText) 'GetSysColor(COLOR_MENUTEXT))
clrPrevBkgnd = SetBkColor(lpdis.hdc, iTemArr(id).ColorBack) 'GetSysColor(COLOR_MENU))
End If
'leave space for checkmark
'may use GetMenuCheckMarkDimensions
x = lpdis.rcItem.Left + 20 '20 la khoang cach thut dau dong cua MenuItem
y = lpdis.rcItem.Top
hfntPrev = SelectObject(lpdis.hdc, MyItem(id).hFont)
ExtTextOut lpdis.hdc, x, y, ETO_OPAQUE, _
lpdis.rcItem, Trim(" "), 1&, 0&
TextOut lpdis.hdc, x, y, MyItem(id).szItemText, MyItem(id).cchItemText
'may put some bitblt function here also.
SetTextColor lpdis.hdc, clrPrevText
SetBkColor lpdis.hdc, clrPrevBkgnd
SelectObject lpdis.hdc, hfntPrev
End Sub
'Thu tuc xu ly kich thuoc Menu phu hop voi tung Item, trong thong diep WM_MEASUREITEM
Function OnMeasureItem(hwnd As Long, lpmis As MEASUREITEMSTRUCT) As MEASUREITEMSTRUCT
Dim xM As MEASUREITEMSTRUCT, hfntOld As Long
Dim S As size, hdc As Long
'find DC
hdc = GetDC(hwnd)
hfntOld = SelectObject(hdc, MyItem(lpmis.itemData).hFont)
GetTextExtentPoint hdc, MyItem(lpmis.itemData).szItemText, _
MyItem(lpmis.itemData).cchItemText, S
'set menu item rect
xM.itemWidth = S.cx + 11
xM.itemHeight = S.cy
SelectObject hdc, hfntOld
ReleaseDC hwnd, hdc
LSet OnMeasureItem = xM
End Function
[/gpecode]
Thủ tục, Hàm theo phương pháp SubClass để bẫy thông điệp.
[gpecode=vb]
'Khai bao bien chung
Public OldWindowProc
Public Sub SubClass_Sheet()
'hwndP = FindWindow("XLMAIN", Application.Caption)
OldWindowProc = SetWindowLong(Application.hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
End Sub
Public Sub Disable_SubClass()
'hwndP = FindWindow("XLMAIN", Application.Caption)
Disable_System_Menu = False
DestroyMenu hMenu
SetWindowLong Application.hwnd, GWL_WNDPROC, OldWindowProc
End Sub
'Ham CallBack
Public Function NewWindowProc(ByVal hwnd As Long, _
ByVal msg As Long, ByVal wparam As Long, _
lparam As Long) As Long
Dim dM As DRAWITEMSTRUCT
Dim mM As MEASUREITEMSTRUCT
Select Case msg
'Xu ly thong diep he thong ve Menu
Case WM_DRAWITEM
MemCopy dM, lparam, Len(dM)
OnDrawMenuItem dM
'Xu ly thong diep kich thuoc Menu
Case WM_MEASUREITEM
MemCopy mM, lparam, Len(mM)
mM = OnMeasureItem(hwnd, mM)
MemCopy lparam, mM, Len(mM)
'Co the bo sung de xu ly cac thong diep khac neu muon
Case WM_COMMAND
'Co the xu ly lenh Menu o day
Case Else
End Select
'Tra ve he thong tu xu ly cac thong diep con lai
NewWindowProc = CallWindowProc(OldWindowProc, _
hwnd, msg, wparam, VarPtr(lparam))
End Function
[/gpecode]
Ví dụ ta tùy biến với menu chuột phải tại Sheet1, ta tạo 1 nút lệnh để bật tắt Menu, chèn code sau vào sheet1
[gpecode=vb]
Private Sub CommandButton1_Click()
If CommandButton1.caption = "Start" Then
Disable_System_Menu = True
Create_Menu
SubClass_Sheet
CommandButton1.caption = "Stop"
Else
Disable_SubClass
CommandButton1.caption = "Start"
End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = Disable_System_Menu
If Cancel = True Then Display_Menu
End Sub
[/gpecode]
(Mọi người tham khảo thêm theo file đính kèm)
