Tặng các bạn Unicode Menu trong Userform - UMU (SourceCode)

Liên hệ QC
Nguyễn Duy Tuân

Nguyễn Duy Tuân

Nghị Hách
Thành viên danh dự
Tham gia
13/6/06
Bài viết
4,737
Được thích
10,243
Giới tính
Nam
Nghề nghiệp
Giáo viên, CEO tại Bluesofts
UMU - Unicode Menu In Userform Version 1.2.2
Gửi tặng các bạn mã nguồn về tạo Unicode Menu trong Userform.

Demo.jpg

UMU - Unicode Menu In Userform là bộ mã nguồn (OpenSource) tạo menu trên userform trong VBA (Excel, Word,,...) với chuẩn unicode. Bộ mã thiết kế một menu ngang chuẩn và mở, người dùng chỉ cần nhập nội dung menu vào sheet "data", khi chạy menu sẽ lấy dữ liệu từ đó để hiển thị. Menu cho phép hiển thị: Radio, Checkbook, Image (ảnh), Label, Label với tiêu đề và mô tả, hiển thị với kiểu chữ, màu sắc phong phú. Khi download về chạy chắc chắn bạn sẽ thực sự nhạc nhiên...

Kỹ thuật lập trình trong bộ code menu trong userform này là ứng dụng hệ thống các hàm Windows API theo hệ unicode. Kỹ thuật lập trình này hay và mạnh nhưng không phải dễ học. Các bạn có thể cứ đưa vào ứng dụng rồi học dần dần.

Rất mong nhận được ý kiến góp ý của các bạn để UMU được hoàn thiện hơn.

Phiên bản mới nhất UniMenuInUserform 1.2.2, ngày 26/10/2015.

Download UniMenuInUserform v1.2.2

[GPECODE=vb]
'MODULE MenuAPIs
Public Declare Function CreateMenu Lib "user32.dll" () As Long
Public Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function SetMenu Lib "user32.dll" (ByVal hwnd As Long, ByVal hMenu As Long) As Long

Public Declare Function SetMenuItemBitmaps Lib "user32.dll" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Public Declare Function SetMenuItemInfo Lib "user32.dll" Alias "SetMenuItemInfoW" (ByVal hMenu As Long, ByVal un As Long, ByVal BOOL As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Public Declare Function SetMenuItemInfoStr Lib "user32.dll" Alias "SetMenuItemInfoW" (ByVal hMenu As Long, ByVal un As Long, ByVal BOOL As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO_STRINGDATA) As Long
Public Declare Function SetMenuItemInfoDATA Lib "user32.dll" Alias "SetMenuItemInfoW" (ByVal hMenu As Long, ByVal un As Long, ByVal BOOL As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO_USERDATA) As Long
Public Declare Function SetMenuContextHelpId Lib "user32.dll" (ByVal hMenu As Long, ByVal dW As Long) As Long
Public Declare Function SetMenuDefaultItem Lib "user32.dll" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPos As Long) As Long
Public Declare Function InsertMenu Lib "user32.dll" Alias "InsertMenuW" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Public Declare Function InsertMenuItem Lib "user32.dll" Alias "InsertMenuItemW" (ByVal hMenu As Long, ByVal un As Long, ByVal BOOL As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Public Declare Function InsertMenuItemDATA Lib "user32.dll" Alias "InsertMenuItemW" (ByVal hMenu As Long, ByVal un As Long, ByVal BOOL As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO_USERDATA) As Long
Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuW" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long

Public Declare Function DrawMenuBar Lib "user32.dll" (ByVal hwnd As Long) As Long
Public Declare Function CheckMenuItem Lib "user32.dll" (ByVal hMenu As Long, ByVal wIDCheckItem As Long, ByVal wCheck As Long) As Long
Public Declare Function CheckMenuRadioItem Lib "user32.dll" (ByVal hMenu As Long, ByVal un1 As Long, ByVal un2 As Long, ByVal un3 As Long, ByVal un4 As Long) As Long
Public Declare Function EnableMenuItem Lib "user32.dll" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long

Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function GetMenuString Lib "user32" Alias "GetMenuStringW" (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long
Public Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoW" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Public Declare Function GetMenuItemInfoDATA Lib "user32" Alias "GetMenuItemInfoW" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO_USERDATA) As Long
Public Declare Function GetMenuItemInfoStr Lib "user32" Alias "GetMenuItemInfoW" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO_STRINGDATA) As Long
Public Declare Function GetMenuState Lib "user32" (ByVal hMenu As Long, ByVal wID As Long, ByVal wFlags As Long) As Long
Public Declare Function GetMenuItemRect Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal uItem As Long, lprcItem As RECT) As Long
Public Declare Function GetMenuDefaultItem Lib "user32" (ByVal hMenu As Long, ByVal fByPos As Long, ByVal gmdiFlags As Long) As Long
Public Declare Function GetMenuContextHelpId Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long
Public Declare Function GetSystemMenu Lib "user32.dll" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Public Declare Function ModifyMenu Lib "user32.dll" Alias "ModifyMenuW" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Public Declare Function RemoveMenu Lib "user32.dll" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Public Declare Function DeleteMenu Lib "user32.dll" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Public Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function MenuItemFromPoint Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal ptScreen As POINTAPI) As Long
Public Declare Function HiliteMenuItem Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal wIDHiliteItem As Long, ByVal wHilite As Long) As Long
'CODE
Function ShortcutMenu(ByVal hSubMenu As Long) As Long 'OnRightClick
On Error GoTo EndFunc
Dim IDM&, UMU_MII As UMU_MenuItemInfo
Dim pt As POINTAPI, rc As RECT
Dim rngMenu As Range

If hSubMenu = 0 Then GoTo EndFunc

GetCursorPos pt
IDM = TrackPopupMenu(hSubMenu, TPM_RETURNCMD, pt.X, pt.Y, 0, GetActiveWindow, rc)
'Debug.Print IDM
If IDM = 0 Then GoTo EndFunc

OnCommand IDM

EndFunc:
ShortcutMenu = IDM
If Err.Number Then Debug.Print Err.Number, Err.Description
End Function

Function OnMeasureItemMenu(ByVal hwnd As Long, MI As MEASUREITEMSTRUCT) As Long

On Error GoTo EndFunc

Dim hdc&
Dim wstr1$, wstr2$, UMU_MII As UMU_MenuItemInfo
Dim Pic As StdPicture, sz As Size

'Get the information of menuitem
If GetMenuItemByID(MI.itemID, UMU_MII) < 0 Then
GoTo EndFunc
End If

'wstr1 = StrConv(UMU_MII.lpName, vbFromUnicode)
'wstr2 = StrConv(UMU_MII.lpDetails, vbFromUnicode)
wstr1 = UMU_MII.lpName
wstr2 = UMU_MII.lpDetails

If UMU_MII.BITMAP <> "" Then
Set Pic = GetPicture(UMU_MII.BITMAP) 'Picture
End If

hdc = GetDC(hwnd)
If (Not Pic Is Nothing) Then
MI.ItemWidth = Pic.Width \ DeltaScrX 'PicWidth
MI.ItemHeight = Pic.Height \ DeltaScrY 'PicHeight

MI.ItemHeight = MI.ItemHeight + 4
Else
If wstr2 <> "" Then 'MultiRow
MI.ItemHeight = PicHeight + 4 'The same pic's width
Else 'single row
MI.ItemHeight = mvarItemHeight
End If
End If

'Reset
If UMU_MII.ImgWidth > 0 Then
MI.ItemWidth = UMU_MII.ImgWidth 'PicWidth
End If
If UMU_MII.ImgHeight > 0 Then
MI.ItemHeight = UMU_MII.ImgHeight + 4 'PicHeight + 4
End If

If MI.ItemWidth < mvarItemHeight Then MI.ItemWidth = mvarItemHeight

If UMU_MII.lpName = "-" Then
If Theme = ThemeSystem Or Theme = ThemeOffice2000 Then
MI.ItemHeight = 11
Else
MI.ItemHeight = 5
End If
Else
If MI.ItemHeight < mvarItemHeight Then MI.ItemHeight = mvarItemHeight
End If
'Convert to unicode string
'wstr1 = StrConv(wstr1, vbUnicode)

GetTextExtentPointStr32 hdc, wstr1, Len(wstr1), sz
'Debug.Print wstr1, Len(wstr1) \ 2, sz.cx, mi.ItemWidth
MI.ItemWidth = MI.ItemWidth + sz.cx \ 2 + GetSystemMetrics(SM_CXMENUCHECK) + IIf(Pic Is Nothing, 24, 0)
ReleaseDC hwnd, hdc
Set Pic = Nothing
Exit Function
EndFunc:

If Err.Number <> 0 Then
Debug.Print "Error in OnMeasureItem Function: ", Err.Number, Err.Description
End If

End Function

Function OnDrawItemMenu(ByVal hwnd As Long, di As DRAWITEMSTRUCT) As Long

On Error GoTo EndFunc

Dim rc As RECT
Dim bSelected As Boolean, bEnabled As Boolean, bChecked As Boolean
Dim uflagDT&, clText&, hBr&, bmpHDC&, oldPic&, hFont&, hPrevFont&
Dim wstr1$, wstr2$, UMU_MII As UMU_MenuItemInfo
Dim Pic As StdPicture, br As LOGBRUSH, sz As Size, iArrMenu&

'Get the information of menuitem
iArrMenu = GetMenuItemByID(di.itemID, UMU_MII)
If iArrMenu < 0 Then
GoTo EndFunc
End If

wstr1 = UMU_MII.lpName
wstr2 = UMU_MII.lpDetails

'Convert to unicode string
'wstr1 = StrConv(wstr1, vbUnicode)
'wstr2 = StrConv(wstr2, vbUnicode)
UMU_MII.ImgWidth = UMU_MII.ImgWidth * DeltaScrX
UMU_MII.ImgHeight = UMU_MII.ImgHeight * DeltaScrY
If UMU_MII.BITMAP <> "" Then
Set Pic = GetPicture(UMU_MII.BITMAP) 'Picture
If Not Pic Is Nothing Then
If UMU_MII.ImgWidth <= 0 Then
UMU_MII.ImgWidth = Pic.Width
End If
If UMU_MII.ImgHeight <= 0 Then
UMU_MII.ImgHeight = Pic.Height
End If
End If
End If

'Set color
If DrawStyle = dsOwnerdraw Then
If UMU_MII.BkColor = 0 Or (mvarResetColors And UMU_MII.BkColor <> mvarBkColor) Then UMU_MII.BkColor = mvarBkColor
If UMU_MII.SelBkColor = 0 Or (mvarResetColors And UMU_MII.SelBkColor <> mvarSelBkColor) Then UMU_MII.SelBkColor = mvarSelBkColor
If UMU_MII.TextColor = 0 Or (mvarResetColors And UMU_MII.TextColor <> mvarTextColor) Then UMU_MII.TextColor = mvarTextColor
If UMU_MII.SelTextColor = 0 Or (mvarResetColors And UMU_MII.SelTextColor <> mvarSelTextColor) Then UMU_MII.SelTextColor = mvarSelTextColor
ElseIf DrawStyle = dsAuto Then
If UMU_MII.oldBkColor = 0 Then UMU_MII.BkColor = mvarBkColor
If UMU_MII.oldSelBkColor = 0 Then UMU_MII.SelBkColor = mvarSelBkColor
If UMU_MII.oldTextColor = 0 Then UMU_MII.TextColor = mvarTextColor
If UMU_MII.oldSelTextColor = 0 Then UMU_MII.SelTextColor = mvarSelTextColor
End If

bEnabled = Not ((di.itemState And ODS_DISABLED) = ODS_DISABLED)
bSelected = (di.itemState And ODS_SELECTED) = ODS_SELECTED
bChecked = (di.itemState And ODS_CHECKED) = ODS_CHECKED

If bSelected Then
br.lbColor = UMU_MII.SelBkColor 'GetSysColor(COLOR_HIGHLIGHT)
clText = UMU_MII.SelTextColor ' GetSysColor(COLOR_HIGHLIGHTTEXT) 'vbYellow '
Else
br.lbColor = UMU_MII.BkColor
If UMU_MII.lpName <> "" And UMU_MII.lpDetails <> "" Then
clText = UMU_MII.TextColor 'vbBlue
Else
clText = UMU_MII.TextColor 'GetSysColor(COLOR_MENUTEXT)
End If
End If

If Not bEnabled Then
clText = GetSysColor(COLOR_GRAYTEXT)
End If

rc = di.rcItem
SetTextColor di.hdc, clText
hBr = CreateBrushIndirect(br)

If bSelected Then
If bEnabled Then
If (Theme = ThemeOffice2000) Then

End If
FillRect di.hdc, rc, hBr
End If
Else
FillRect di.hdc, rc, hBr
End If

rc = di.rcItem
If Not Pic Is Nothing Then
bmpHDC = CreateCompatibleDC(di.hdc)
oldPic = SelectObject(bmpHDC, Pic.Handle)

'Debug.Print Err
'Debug.Print "pic.Handle", pic.Handle
'BitBlt di.hdc, di.rcItem.Left, di.rcItem.Top, pic.Width, pic.Height, bmpHDC, 0, 0, SRCCOPY 'NOTSRCCOPY
If Theme = ThemeOffice2000 Then
End If

StretchBlt di.hdc, di.rcItem.Left + 2, di.rcItem.Top + 2, UMU_MII.ImgWidth, _
UMU_MII.ImgHeight, bmpHDC, 0, 0, Pic.Width, Pic.Height, SRCCOPY

'SelectObject bmpHDC, oldPic
DeleteDC bmpHDC
DeleteObject oldPic
rc.Left = rc.Left + UMU_MII.ImgWidth \ DeltaScrX + 4
End If
DeleteObject hBr
SetBkMode di.hdc, Transparent
If Pic Is Nothing Then
rc.Left = rc.Left + GetSystemMetrics(SM_CXMENUCHECK) + 2
End If

rc.Left = rc.Left + 5
rc.Right = rc.Right - 1
If bChecked Or UMU_MII.GroupID > -1 Or UMU_MII.CtrlType = UMU_CtrlCheckBox Then
rc.Left = rc.Left + 5
End If
If wstr2 <> "" Then
rc.Top = rc.Top + 2
hFont = CreateFont(-MulDiv(8, GetDeviceCaps(di.hdc, LOGPIXELSY), 72), 0, 0, 0, FW_EXTRABOLD, 0, 0, 0, 0, 0, 0, 0, 0, StrPtr("Tahoma"))
hPrevFont = SelectObject(di.hdc, hFont)
If Pic Is Nothing Then
DrawText di.hdc, StrPtr(wstr1), Len(wstr1), rc, DT_LEFT
Else
DrawText di.hdc, StrPtr(wstr1), Len(wstr1), rc, DT_CENTER
End If
GetTextExtentPoint32 di.hdc, wstr1, Len(wstr1), sz
If hPrevFont <> 0 Then
SelectObject di.hdc, hPrevFont
End If
DeleteObject hFont '//DeleteObject SelectObject (di.hdc, hPrevFont)
Else 'Single line
DrawText di.hdc, StrPtr(wstr1), Len(wstr1), rc, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
End If

If wstr2 <> "" Then
rc.Top = rc.Top + sz.cy + 3
rc.Left = rc.Left + IIf(Pic Is Nothing, 0, 2)
DrawText di.hdc, StrPtr(wstr2), Len(wstr2), rc, DT_LEFT Or DT_WORDBREAK
End If

' Separator:
If UMU_MII.bSeparator Then
rc = di.rcItem
rc.Top = (rc.Bottom - rc.Top - 2) \ 2 + rc.Top
rc.Bottom = rc.Top + 2
If (Theme = ThemeOffice2000) Then
End If
DrawEdge di.hdc, rc, BDR_SUNKENOUTER, BF_TOP Or BF_BOTTOM
End If

If (Theme = ThemeOffice2000) Then
End If

If bChecked Then
rc = di.rcItem
rc.Right = 20
If Pic Is Nothing Then
If Not bEnabled Then
SetTextColor di.hdc, GetSysColor(COLOR_GRAYTEXT)
ElseIf Theme = ThemeOffice2000 Then
End If
hFont = CreateFont(-MulDiv(10, GetDeviceCaps(di.hdc, LOGPIXELSY), 72), 0, 0, 0, FW_SEMIBOLD, 0, 0, 0, SYMBOL_CHARSET, 0, 0, 0, 0, StrPtr("Marlett"))
hPrevFont = SelectObject(di.hdc, hFont)
If UMU_MII.GroupID > -1 Then 'Radio
DrawText di.hdc, StrPtr("h"), Len("h"), rc, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
Else
DrawText di.hdc, StrPtr("a"), Len("a"), rc, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
End If
DeleteObject SelectObject(di.hdc, hPrevFont)
End If
End If

Set Pic = Nothing
Exit Function
EndFunc:

If Err.Number <> 0 Then
Debug.Print "Error in OnDrawItem Function: ", Err.Number, Err.Description
End If

End Function
[/GPECODE]

Nếu thấy hay xin đừng quên "Thanks" %#^#$!
 

File đính kèm

  • UniMenuInUserform.zip
    173.2 KB · Đọc: 5,266
  • UniMenuInUserform 1.1.zip
    238.2 KB · Đọc: 4,790
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Hiện nay bộ code Unicode menu in userform chỉ chạy trong môi trường Office 32-bit. Tới đây nếu thu xếp được thời gian mình sẽ chỉnh sửa để chạy được cả 2 môi trường 32 và 64-bit.
 
Upvote 0
Anh Tuấn ơi!
Anh xem giúp tại sao mình chọn lọc lấy 3 người có số phiếu trên 50% và người có tuổi lo971n hơn trúng cử, nhưng kết quả lại là 4 người có số phiếu trên 50% vậy.
Mong Anh giúp và hướng dẫn thêm nhé.
Cám ơn Anh nhiều. (có gửi File kèm theo)
 

File đính kèm

  • THI TRAN.xls
    983.5 KB · Đọc: 67
Upvote 0
Thaiduc đã viết:
Anh Tuấn ơi!
Anh xem giúp tại sao mình chọn lọc lấy 3 người có số phiếu trên 50% và người có tuổi lo971n hơn trúng cử, nhưng kết quả lại là 4 người có số phiếu trên 50% vậy.
Mong Anh giúp và hướng dẫn thêm nhé.
Cám ơn Anh nhiều. (có gửi File kèm theo)
Nhấp chuột vào đây để mở rộng...

Bạn chỉ ra sheet nào và yêu cầu lọc ra sao?
 
Upvote 0
Nhân tiện bạn có ý sửa và làm phiên bản 64 bit tôi góp ý chút.
Hồi xa xưa, khi tôi mới tham gia GPE, tôi từng định góp ý nhưng thấy bạn không quan tâm nên thôi. Bây giờ thấy đã có tận phiên bản 1.2.2 nhưng những lỗi tôi phát hiện vẫn còn nên chỉ ra để bạn sửa. Tôi cũng có thể đề xuất phương án sửa nhưng đây là sản phẩm của bạn. Tôi chỉ chỉ ra lỗi và cho biết nguyên nhân.

1. Bạn hãy mở UserForm. Lúc này bạn có menu "tự vẽ", tiếng Việt. Bây giờ bạn mở menu Ngôn ngữ và chọn mục menu English. Lúc này bạn có tiếng Anh. Bạn mở menu Options chỉ để hiển thị, không chọn gì cả (nhiều khi click nhầm, click xong nghĩ lại và thôi) mà click trên Form để đóng menu. Từ lúc này bạn có thể thay đổi ngôn ngữ qua lại bao nhiêu lần tùy thích nhưng cứ chọn ngôn ngữ Việt là bạn có menu Options như hình1 đính kèm.
Nguyên nhân:
The window receives a WM_MEASUREITEM message before the menu is displayed for the first time
Nhấp chuột vào đây để mở rộng...
Có nghĩa là với mỗi drop-down menu và submenu thì thông điệp WM_MEASUREITEM chỉ được gửi 1 lần duy nhất ở thời điểm trước khi menu đó được hiển thị lần đầu tiên. Trong các lần hiển thị tiếp theo của menu đó thì WM_MEASUREITEM không được gửi. Vậy thì nếu lần mở đầu tiên các text có độ dài nhỏ thì trong OnMeasureItemMenu bạn tính chiều dài dựa trên các text ngắn đó (nếu submenu có vd. 5 mục con thì bạn trả về cho Windows 5 độ rộng và Windows sẽ lấy giá trị lớn nhất làm độ rộng của submenu). Khi đổi xong ngôn ngữ bạn mở lại menu đó thì do WM_MEASUREITEM không được gửi nữa nên chiều rộng của menu vẫn thế nhưng text đã thay đổi do đổi ngôn ngữ. Nếu text ở ngôn ngữ mới này dài hơn thì nó bị cắt cụt. Nói đúng hơn là bạn vẽ nhưng đoạn nằm ngoài chiều rộng menu sẽ không có.

Lưu ý là những cái tôi viết ở trên là cho phiên bản hồi xưa.

Bây giờ thì chả cần làm gì cả cứ Show Form rồi chọn menu bất kỳ thì các submenu đều bị cắt cụt (trong tất cả các menu chính). Vd. trong menu "Tùy chọn" như hinh2 đính kèm.

2. Trong UserForm_Initialize bạn thay

MyUMUMenu.DrawStyle = dsOwnerdraw

thành

MyUMUMenu.DrawStyle = dsSystem

Bạn mở UserForm. Lúc này bạn có menu do system tự vẽ, tiếng Việt. Bạn có thể thay đổi ngôn ngữ (click ckLang) bao nhiêu lần tùy ý thì chỉ có text trên thanh menu là thay đổi, còn text của các mục menu trong drop-down menu và submenu LUÔN LUÔN là tiếng Việt.

Nguyên nhân: nó ở đoạn code này (ở phiên bản xa xưa, ở phiên bản mới tôi lười không xem lại)
Mã: 
Sub ChangeLang()
    Dim I As Long, szName$, szDetail$

    For I = 1 To MenuItemCount
        With ArrayPopupMenus(I)
            .lpName = mMenuData(.RowID, nIndexOfMenuName).Value
            .lpDetails = mMenuData(.RowID, nIndexOfMenuDetails).Value
            If .ParentID = 0 Then
                ModifyMenu hMenu, .ID, MF_BYCOMMAND Or MF_STRING, .ID, StrPtr(.lpName)
            End If
        End With
    Next I
 
End Sub
Nhìn code là biết nếu là dsSystem thì Windows chỉ có những text mà bạn cung cấp khi tạo menu, tức tiếng Việt. Bạn chỉ thay đổi (ModifyMenu) cho các mục menu chính. Khi là dsOwnerdraw thì không sao vì lúc đó "bạn" tự vẽ và bạn lấy text ở cấu trúc UMU_MenuItemInfo, đã có text thay đổi trong block With ... End With
-------------
Trong lập trình thì không ai có thể phát hiện ra tất cả các lỗi, kể cả ông lớn phần mềm là Windows. Chuyện phát hiện ra lỗi là khó nhất vì khó lường được mọi tình huống. Nhưng nếu đã biết lỗi ở đâu thì chuyện sửa là chuyện nhỏ. Bạn biết tạo menu, biết thêm mục menu, thay đổi và xóa có nghĩa là bạn đã biết làm tất cả. Bạn có thể tự sửa được.

Tôi cũng cảm thấy là lỗi 1 nếu người dùng không biết lập trình mà chỉ thử hoạt động nhưng thử không kỹ thì khó phát hiện ra lỗi. Nhưng bạn phải thừa nhận với tôi là lỗi 2 nó hiện ra liền nếu ta chọn phương án cho system vẽ. Vì vậy tôi ngạc nhiên là sao không có ai phát hiện ra.
 

File đính kèm

  • hinh1.JPG
    hinh1.JPG
    115.2 KB · Đọc: 73
  • hinh2.JPG
    hinh2.JPG
    66.2 KB · Đọc: 75
Upvote 0
batman1 đã viết:
Nhân tiện bạn có ý sửa và làm phiên bản 64 bit tôi góp ý chút.
Hồi xa xưa, khi tôi mới tham gia GPE, tôi từng định góp ý nhưng thấy bạn không quan tâm nên thôi. Bây giờ thấy đã có tận phiên bản 1.2.2 nhưng những lỗi tôi phát hiện vẫn còn nên chỉ ra để bạn sửa. Tôi cũng có thể đề xuất phương án sửa nhưng đây là sản phẩm của bạn. Tôi chỉ chỉ ra lỗi và cho biết nguyên nhân.

1. Bạn hãy mở UserForm. Lúc này bạn có menu "tự vẽ", tiếng Việt. Bây giờ bạn mở menu Ngôn ngữ và chọn mục menu English. Lúc này bạn có tiếng Anh. Bạn mở menu Options chỉ để hiển thị, không chọn gì cả (nhiều khi click nhầm, click xong nghĩ lại và thôi) mà click trên Form để đóng menu. Từ lúc này bạn có thể thay đổi ngôn ngữ qua lại bao nhiêu lần tùy thích nhưng cứ chọn ngôn ngữ Việt là bạn có menu Options như hình1 đính kèm.
Nguyên nhân:

Có nghĩa là với mỗi drop-down menu và submenu thì thông điệp WM_MEASUREITEM chỉ được gửi 1 lần duy nhất ở thời điểm trước khi menu đó được hiển thị lần đầu tiên. Trong các lần hiển thị tiếp theo của menu đó thì WM_MEASUREITEM không được gửi. Vậy thì nếu lần mở đầu tiên các text có độ dài nhỏ thì trong OnMeasureItemMenu bạn tính chiều dài dựa trên các text ngắn đó (nếu submenu có vd. 5 mục con thì bạn trả về cho Windows 5 độ rộng và Windows sẽ lấy giá trị lớn nhất làm độ rộng của submenu). Khi đổi xong ngôn ngữ bạn mở lại menu đó thì do WM_MEASUREITEM không được gửi nữa nên chiều rộng của menu vẫn thế nhưng text đã thay đổi do đổi ngôn ngữ. Nếu text ở ngôn ngữ mới này dài hơn thì nó bị cắt cụt. Nói đúng hơn là bạn vẽ nhưng đoạn nằm ngoài chiều rộng menu sẽ không có.

Lưu ý là những cái tôi viết ở trên là cho phiên bản hồi xưa.

Bây giờ thì chả cần làm gì cả cứ Show Form rồi chọn menu bất kỳ thì các submenu đều bị cắt cụt (trong tất cả các menu chính). Vd. trong menu "Tùy chọn" như hinh2 đính kèm.

2. Trong UserForm_Initialize bạn thay

MyUMUMenu.DrawStyle = dsOwnerdraw

thành

MyUMUMenu.DrawStyle = dsSystem

Bạn mở UserForm. Lúc này bạn có menu do system tự vẽ, tiếng Việt. Bạn có thể thay đổi ngôn ngữ (click ckLang) bao nhiêu lần tùy ý thì chỉ có text trên thanh menu là thay đổi, còn text của các mục menu trong drop-down menu và submenu LUÔN LUÔN là tiếng Việt.

Nguyên nhân: nó ở đoạn code này (ở phiên bản xa xưa, ở phiên bản mới tôi lười không xem lại)
Mã: 
Sub ChangeLang()
    Dim I As Long, szName$, szDetail$

    For I = 1 To MenuItemCount
        With ArrayPopupMenus(I)
            .lpName = mMenuData(.RowID, nIndexOfMenuName).Value
            .lpDetails = mMenuData(.RowID, nIndexOfMenuDetails).Value
            If .ParentID = 0 Then
                ModifyMenu hMenu, .ID, MF_BYCOMMAND Or MF_STRING, .ID, StrPtr(.lpName)
            End If
        End With
    Next I
 
End Sub
Nhìn code là biết nếu là dsSystem thì Windows chỉ có những text mà bạn cung cấp khi tạo menu, tức tiếng Việt. Bạn chỉ thay đổi (ModifyMenu) cho các mục menu chính. Khi là dsOwnerdraw thì không sao vì lúc đó "bạn" tự vẽ và bạn lấy text ở cấu trúc UMU_MenuItemInfo, đã có text thay đổi trong block With ... End With
-------------
Trong lập trình thì không ai có thể phát hiện ra tất cả các lỗi, kể cả ông lớn phần mềm là Windows. Chuyện phát hiện ra lỗi là khó nhất vì khó lường được mọi tình huống. Nhưng nếu đã biết lỗi ở đâu thì chuyện sửa là chuyện nhỏ. Bạn biết tạo menu, biết thêm mục menu, thay đổi và xóa có nghĩa là bạn đã biết làm tất cả. Bạn có thể tự sửa được.

Tôi cũng cảm thấy là lỗi 1 nếu người dùng không biết lập trình mà chỉ thử hoạt động nhưng thử không kỹ thì khó phát hiện ra lỗi. Nhưng bạn phải thừa nhận với tôi là lỗi 2 nó hiện ra liền nếu ta chọn phương án cho system vẽ. Vì vậy tôi ngạc nhiên là sao không có ai phát hiện ra.
Nhấp chuột vào đây để mở rộng...

Cảm ơn anh đã phân tích cơ chế của WM_MEASUREITEM rất kỹ, đúng là em k chú ý tới cơ chế làm việc của nó là chỉ lần đầu tiên đc gọi, cứ nghĩ mỗi lần vẽ menu là nó chạy lại để tính toán kích thươvs item. Trong bộ code này còn một lỗi nghiêm trọng nữa là tràn bộ nhớ, em đã từng tìm nguyên nhân nhưng chưa ra. Lâu quá bỏ bê code này, thời gian tới chắc e sẽ xem xét và tìm cách fix, sẵn nhờ anh nếu thu xếp đc time thì kiểm tra giúp lỗi tràn bộ nhớ.

Cảm ơn anh!
 
Upvote 0
Nguyễn Duy Tuân đã viết:
sẵn nhờ anh nếu thu xếp đc time thì kiểm tra giúp lỗi tràn bộ nhớ.
Nhấp chuột vào đây để mở rộng...
Tôi không hiểu lắm. Tràn bộ nhớ? Biểu hiện thế nào, sảy ra trong những tình huống nào? Tôi hỏi vì tôi không sử dụng nên không phát hiện được tràn bộ nhớ.
 
Upvote 0
batman1 đã viết:
Tôi không hiểu lắm. Tràn bộ nhớ? Biểu hiện thế nào, sảy ra trong những tình huống nào? Tôi hỏi vì tôi không sử dụng nên không phát hiện được tràn bộ nhớ.
Nhấp chuột vào đây để mở rộng...

Anh mở form có menu lên, để chuột mở qua mở lại nhiều lần menu (cho nó vẽ đi vẽ lại). Thì Windows chạy chậm đi (cảm giác nhưng đúng), đến một lúc nào đó thì Excel vẽ màu sắc lung tung.
 
Upvote 0
Nguyễn Duy Tuân đã viết:
Anh mở form có menu lên, để chuột mở qua mở lại nhiều lần menu (cho nó vẽ đi vẽ lại). Thì Windows chạy chậm đi (cảm giác nhưng đúng), đến một lúc nào đó thì Excel vẽ màu sắc lung tung.
Nhấp chuột vào đây để mở rộng...
Khó nhất là những lỗi mà không phải lúc nào cũng sảy ra. Và những lỗi sảy ra sau một thời gian dài.
Tôi không đủ kiên nhẫn để test. Tôi mở đi mở lại menu nhưng không thấy vấn đề gì. Sau một thời gian mỏi tay quá nên tôi thôi. Chỉ còn việc dò xem code trong OnDrawItemMenu

1. Về brush và Font thì có DeleteObject.

2. Về bitmap ...
Có
Mã: 
If Not Pic Is Nothing Then
    bmpHDC = CreateCompatibleDC(di.hdc)
    oldPic = SelectObject(bmpHDC, Pic.Handle)
    ... 
    'SelectObject bmpHDC, oldPic
    DeleteDC bmpHDC
    DeleteObject oldPic
End If
Trong help có:
"The SelectObject function selects an object into the specified device context. The new object replaces the previous object of the same type
...
This function returns the previously selected object of the specified type. An application should always replace a new object with the original, default object after it has finished drawing with the new object. "

Như thế thì không biết có thể tự mình DeleteObject oldPic được không. Tôi không dám chắc về điều này. Mà tôi cũng không bao giờ thử DeleteObject oldPic, vì tôi luôn làm theo help mà không thử làm khác đi bao giờ.

Theo tôi nên chọn oldPic vào lại device context bmpDC. Sau đó gọi DeleteDC. Còn system làm gì với oldPic và hủy khi nào thì system tự lo liệu. Làm như thế để khỏi áy náy, băn khoăn ;)

Tức nếu là tôi thì
Mã: 
If Not Pic Is Nothing Then
    bmpHDC = CreateCompatibleDC(di.hdc)
    oldPic = SelectObject(bmpHDC, Pic.Handle)
    ... 
    SelectObject bmpHDC, oldPic
    DeleteDC bmpHDC
End If

Các code khác tôi cũng lướt qua nhưng không thấy gì đáng ngờ cả. Về API thì mọi cái đều được làm bài bản. Cái này thì tôi chịu.
 
Upvote 0
Các bác nào download xong bản 1.2.2 thì có thể share lại giúp em với. Em đã vào link của bài #1 để làm theo hướng dẫn mà hơn 1 tuần rồi vẫn chưa nhận được file.
Cảm ơn các bác trước nha
 
Upvote 0
Mình cũng vửa mới đăng ký theo #1, hy vọng sớm nhận được sản phẩm
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
1
Đọc
59
hoangtuaotrang_hp_vn
H
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
Trả lời
18
Đọc
361
SA_DQ
SA_DQ
kimtanmap
  • Question
Nhờ viết code VBA Macro lập lại.
Trả lời
5
Đọc
114
kimtanmap
kimtanmap
nguyenphuochien166
Cách Vlookup hoặc cách lấy thông tin dữ liệu có dấu mũ lũy thừa?
    • Cười
Trả lời
2
Đọc
18
nguyenphuochien166
nguyenphuochien166
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
1
Đọc
58
hoangtuaotrang_hp_vn
H
C
Chia sẻ: Kết quả xổ số Keno
    • Thích
Trả lời
3
Đọc
126
cantl
C
B
Lọc dữ liệu trùng, đếm số lần, tự tô màu theo điều kiện.
Trả lời
2
Đọc
59
batista911
B
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
0
Đọc
24
huynhnhu1234
huynhnhu1234
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
11
Đọc
193
VetMini
V
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
7
Đọc
111
tranvansau278
T
N
Hàm tìm giá trị theo giờ vào - ra
Trả lời
6
Đọc
101
Nguyễn Linh hn94
N
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
4
Đọc
147
zarra
zarra
Nguyễn Duy Tuân
  • Question
Chia sẻ ControlForOffice - Bộ công cụ điều khiển Office/Excel
    • Thích
6 7 8
Trả lời
148
Đọc
95K
leminhksvl
L
HeSanbi
  • Question
Lỗi VBA: Cài đặt thông số ForceVBALoadFromSource trong Registry để VBA biên dịch không bị lỗi
    • Cảm ơn
    • Thích
Trả lời
5
Đọc
288
anhdepjai
A
H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
18
Đọc
19K
DeTong
D
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
245
Đọc
13K
Hoàng Trọng Hữu
Hoàng Trọng Hữu
D
  • Question
Xin cách sắp xếp dữ liệu theo thứ tự không làm hỏng link
Trả lời
7
Đọc
295
cantl
C
N
Giúp sửa mã code
Trả lời
16
Đọc
269
ptm0412
ptm0412
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
1
Đọc
54
hoangminhtien
hoangminhtien
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
Trả lời
0
Đọc
188
GPE-Trợ Lý
GPE-Trợ Lý
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom