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

[Nguyễn Duy Tuân]

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.

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" !

 

[Nguyễn Duy Tuân]

Chấp thuận LICENSE để sử dụng miễn phí mã nguồn UMU!

Quá tuyệt vời. Xin cảm ơn tác giả nhiều. Và cũng xin mạn phép tác giả cho em xử dụng miễn phí chương trình này vào ứng dụng của em nhé.

Thanks,

Toàn bộ mã nguồn của menu (UMU) bạn có thể sử dụng miễn phí cho ứng dụng của mình, bạn đọc và thực hiện theo LICENSE trong phần About hay trong file gửi kèm nhé!

Khi sản phẩm của bạn sử dụng mã nguồn UMU, bạn có thể mail cho tôi biết tên sản phẩm của bạn.

 

[msc0506]

Cảm ơn

Đúng là quá cao so với VBA

Trước tiên cảm ơn tác giả nhiều nhé !
(Nguyễn Duy Tuân)
Mình đã dùng cho ứng dụng cá nhân của mình rất hay text trên máy mình thì Font ổn định đang mắc phải 1 vấn đề với API đó là mình sử dụng cho from Main nên có dùng thêm MaxMin (OK) ,Icon ,TakBa chứ khi chạy ẩn excel rồi chẳng thấy nó đâu cả , Nhưng khi thêm Hiện trên thanh status của Win thì bị lỗi :

"lpPrevWndProc = SetWindowLong(hParentWindow, GWL_WNDPROC, AddressOf WndProc)"

Mình lại mù tit về API vậy Tác giả và các bạn giúp mình nhé
Đây là Code mình thêm vào :

'API functions
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" _
() As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hWnd As Long) As Long


'Constants
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const GWL_EXSTYLE = (-20)
Private Const HWND_TOP = 0
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_SHOWWINDOW = &H40
Private Const WS_EX_APPWINDOW = &H40000
Private Const GWL_STYLE = (-16)
Private Const WS_MINIMIZEBOX = &H20000
Private Const SWP_FRAMECHANGED = &H20
Private Const WM_SETICON = &H80
Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&

Sub AddIcon()
'Add an icon on the titlebar
Dim hWnd As Long
Dim lngRet As Long
Dim hIcon As Long
hIcon = Sheet1.Image1.Picture.Handle
hWnd = FindWindow(vbNullString, UserForm1.Caption)
lngRet = SendMessage(hWnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
lngRet = SendMessage(hWnd, WM_SETICON, ICON_BIG, ByVal hIcon)
lngRet = DrawMenuBar(hWnd)
End Sub

Sub AppTasklist(myForm)
'Add this userform into the Task bar
Dim WStyle As Long
Dim Result As Long
Dim hWnd As Long

hWnd = FindWindow(vbNullString, myForm.Caption)
WStyle = GetWindowLong(hWnd, GWL_EXSTYLE)
WStyle = WStyle Or WS_EX_APPWINDOW
Result = SetWindowPos(hWnd, HWND_TOP, 0, 0, 0, 0, _
SWP_NOMOVE Or _
SWP_NOSIZE Or _
SWP_NOACTIVATE Or _
SWP_HIDEWINDOW)
Result = SetWindowLong(hWnd, GWL_EXSTYLE, WStyle)
Result = SetWindowPos(hWnd, HWND_TOP, 0, 0, 0, 0, _
SWP_NOMOVE Or _
SWP_NOSIZE Or _
SWP_NOACTIVATE Or _
SWP_SHOWWINDOW)
End Sub

Cảm ơn nhiều

 

[Nguyễn Duy Tuân]

Tốt nhất bạn hãy ghi một cách rõ ràng về lỗi:
+ Bạn đã thêm vào những thủ tục gì ? (Mục đích của thủ tục đó? Mã nguồn?)
+ Tình huống gây lỗi? Hiện tượng ?

Nếu gửi code, bạn hãy, vào bài mới, bấm vào đổi sang khung lớn, đặt code trong

 để dễ nhìn. 

Tốt hơn cả là bạn có thể gửi file có mã nguồn chỉ liên quan đến giao diện thì tôi và mọi người mới có thể tìm giúp bạn nhanh hơn.

 

[msc0506]

Tốt nhất bạn hãy ghi một cách rõ ràng về lỗi:
+ Bạn đã thêm vào những thủ tục gì ? (Mục đích của thủ tục đó? Mã nguồn?)
+ Tình huống gây lỗi? Hiện tượng ?

Mình thêm Minmax ,Icon và TalList cho form Main có dùng Uni Menu nhưng Không được
Bạn giúp mình nhé vì API là mình mù tịt

Đây là code mình thêm vào :

Private Declare Function GetWindowLong Lib "user32" _
                                       Alias "GetWindowLongA" _
                                       (ByVal hWnd As Long, _
                                        ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
                                       Alias "SetWindowLongA" _
                                       (ByVal hWnd As Long, _
                                        ByVal nIndex As Long, _
                                        ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" _
                                      (ByVal hWnd As Long, _
                                       ByVal hWndInsertAfter As Long, _
                                       ByVal X As Long, _
                                       ByVal Y As Long, _
                                       ByVal cx As Long, _
                                       ByVal cy As Long, _
                                       ByVal wFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" _
                                    Alias "FindWindowA" _
                                    (ByVal lpClassName As String, _
                                     ByVal lpWindowName As String) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" _
                                         () As Long
Private Declare Function SendMessage Lib "user32" _
                                     Alias "SendMessageA" _
                                     (ByVal hWnd As Long, _
                                      ByVal wMsg As Long, _
                                      ByVal wParam As Long, _
                                      lParam As Any) As Long
Private Declare Function DrawMenuBar Lib "user32" _
                                     (ByVal hWnd As Long) As Long


'Constants
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const GWL_EXSTYLE = (-20)
Private Const HWND_TOP = 0
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_SHOWWINDOW = &H40
Private Const WS_EX_APPWINDOW = &H40000
Private Const GWL_STYLE = (-16)
Private Const WS_MINIMIZEBOX = &H20000
Private Const SWP_FRAMECHANGED = &H20
Private Const WM_SETICON = &H80
Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&

Sub AddMinimiseButton()
'//Add a Minimize button to Userform
    Dim hWnd As Long
    hWnd = GetActiveWindow
    Call SetWindowLong(hWnd, GWL_STYLE, _
                       GetWindowLong(hWnd, GWL_STYLE) Or _
                       WS_MINIMIZEBOX)
    Call SetWindowPos(hWnd, 0, 0, 0, 0, 0, _
                      SWP_FRAMECHANGED Or _
                      SWP_NOMOVE Or _
                      SWP_NOSIZE)
End Sub
Sub AppTasklist(myForm)
'Add this userform into the Task bar
    Dim WStyle As Long
    Dim Result As Long
    Dim hWnd As Long

    hWnd = FindWindow(vbNullString, myForm.Caption)
    WStyle = GetWindowLong(hWnd, GWL_EXSTYLE)
    WStyle = WStyle Or WS_EX_APPWINDOW
    Result = SetWindowPos(hWnd, HWND_TOP, 0, 0, 0, 0, _
                          SWP_NOMOVE Or _
                          SWP_NOSIZE Or _
                          SWP_NOACTIVATE Or _
                          SWP_HIDEWINDOW)
    Result = SetWindowLong(hWnd, GWL_EXSTYLE, WStyle)
    Result = SetWindowPos(hWnd, HWND_TOP, 0, 0, 0, 0, _
                          SWP_NOMOVE Or _
                          SWP_NOSIZE Or _
                          SWP_NOACTIVATE Or _
                          SWP_SHOWWINDOW)
End Sub

 

[Nguyễn Duy Tuân]

Trong thủ tục AppTasklist, bạn hãy chữa lại
hWnd = FindWindow(vbNullString, myForm.Caption)
thành
hWnd = FindWindow("ThunderDFrame", myForm.Caption)

Việc thêm hai thủ tục AddMinimiseButton và AppTasklist phải được gọi trước lệnh SetUnicodeCaption.

 

[msc0506]

Vẫn bị lỗi bạn ơi

on time error '0'

Mình chỉ cần dùng AppTasklist thôi để khi chạy nhiều ứng dụng thì nó hiện trên statut thôi chứ minmax minh dùng cái này

Option Explicit
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex 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 GWL_STYLE As Long = (-16)
Public Const WS_MAXIMIZEBOX As Long = &H10000
Public Const WS_MINIMIZEBOX = &H20000
Public Sub MinMax(sCaption As String)
Dim hWndForm As Long
Dim iStyle As Long
If Val(Application.Version) < 9 Then
    hWndForm = FindWindow("ThunderXFrame", sCaption)  'XL97
Else
    hWndForm = FindWindow("ThunderDFrame", sCaption)  'XL2000
End If
iStyle = GetWindowLong(hWndForm, GWL_STYLE)
iStyle = iStyle Or WS_MAXIMIZEBOX
iStyle = iStyle Or WS_MINIMIZEBOX
SetWindowLong hWndForm, GWL_STYLE, iStyle
End Sub

Nhưng mình dùng ở Modul mới bạn có thể tích hợp vào luôn modUMUMenu
Thì tuyệt
chỉ còn thiếu Icon và AppTasklist
làmodUMUMenu hoàn hảo là đủ dùng cho ứng dụng

Cảm ơn bạn nhiều !

 

[Nguyễn Duy Tuân]

modUMUMenu và class UMUMenu chỉ để các lệnh xử lý về menu trong dự án "Unicode menu trong Userform", các lệnh tác động với Userform như thay đổi style, icon, resize,...cần làm một class chuyên biệt riêng.

 

[msc0506]

Minh cũng đã tìm và thay nhiều code trên mạng nhưng đều bị xung ở lỗi trên mà API minh ko biết nên bạn có thể giúp mình vụ này được không ? nếu không mình đành bó tay thội

Cảm ơn

 

[levanduyet]

Dear Tuân,
Anh Test phiên bản 1.1 trên :
_ Window Vista.
_ Excel 2007.

Bị báo lỗi tại hàng này:

LVD

 

[Nguyễn Duy Tuân]

Dear Tuân,
Anh Test phiên bản 1.1 trên :
_ Window Vista.
_ Excel 2007.

Bị báo lỗi tại hàng này:

LVD

EM dùng Windows XP + Office 2007 không có lỗi. Có lẽ anh kiểm tra ActiveX Control "MSCOMCT.OCX" xem thế nào.

 

[levanduyet]

Sau khi anh thực hiện update:

http://giaiphapexcel.com/forum/showthread.php?t=19446&page=2

Thì tất cả các control đều được cập nhật. Vậy em theo cái thread anh giới thiệu kiểm tra lại và cập nhật xem sao.

Tks,

LVD

 

[Nguyễn Duy Tuân]

Sau khi anh thực hiện update:

http://giaiphapexcel.com/forum/showthread.php?t=19446&page=2

Thì tất cả các control đều được cập nhật. Vậy em theo cái thread anh giới thiệu kiểm tra lại và cập nhật xem sao.

Tks,

LVD

Đúng là khi cập nhật bộ ActiveX Control từ Micosoft thì bị lỗi, lỗi này do không tương thích về interface.
http://www.microsoft.com/downloads/...35-0403-45c4-9e41-459f0eb89e36&displayLang=en

 

[Nguyễn Duy Tuân]

Đúng là khi cập nhật bộ ActiveX Control từ Micosoft thì bị lỗi, lỗi này do không tương thích về interface.
http://www.microsoft.com/downloads/...35-0403-45c4-9e41-459f0eb89e36&displayLang=en

Lỗi trên xảy ra chỉ với Office 2007. Đây là lỗi của ActiveX Controls khi update VB6->VB6 SP6 của Microsoft trong Office.

 

[levanduyet]

Lỗi trên xảy ra chỉ với Office 2007. Đây là lỗi của ActiveX Controls khi update VB6->VB6 SP6 của Microsoft trong Office.

Bởi vậy mấy file anh viết chẳng sử dụng được.
Chưa khắc phục được ở những máy không có cài VB6.

LVD

 

[cbtm]

Unicode Menu trong Userfor

Trước tiên cám ơn Anh Tuân cho mượn menu form của anh, Nhờ các bạn hoặc anh tuân giúp đở để form gìống như sauUniMenuInUserform 1.1 tiếng anh và Việt thank you

 

[Nguyễn Duy Tuân]

Trước tiên cám ơn Anh Tuân cho mượn menu form của anh, Nhờ các bạn hoặc anh tuân giúp đở để form gìống như sauUniMenuInUserform 1.1 tiếng anh và Việt thank you

Vâng, em đang tranh thủ sửa lại code để thay đổi ngôn ngữ của menu. Em sẽ sớm gửi phiên bản mới lên.

 

[Nguyễn Duy Tuân]

UniMenuInUserform (version 1.2 - new)

Xin gửi các thành viên phiên bản mới của UMU version 1.2

v1.2.0: (01-Dec-2009)
+ Thêm thuộc tính đổi ngôn ngữ, cho phép menu chuyển đổi hai ngôn ngữ Việt Nam hay ngôn ngữ khác như là English.
+ Thay đổi cấu trúc bảng dữ liệu cho menu (Menu Data).
+ Đối tượng ảnh ImageList đặt trong Userform


Download UniMenuInUserform v1.2

 

[Nguyễn Duy Tuân]

UniMenuInUserform (version 1.2.1 - new)

Xin gửi các thành viên phiên bản mới của UMU version 1.2.1

v1.2.1: (03-Dec-2009)
+ Sửa lỗi ImageList trong Userform
+ Lỗi đo độ rọng của chuỗi trong các Menuitem


Download UniMenuInUserform v1.2.1

 

[huynhkimtien]

Cái này rất hay. Nhưng nó bị lỗi Anh Tuân à.
Nếu mình để form ở chế độ "showmodal=false" khi kích vào menu sẽ không hiện ra và còn bị treo nữa chứ. Anh xem lại thử nhé.

 

[duckyhut]

Các bác ơi. Có ai biết làm thế nào để lấy tên của Popup mà mình kích hoạt không à?