ساخت منوهای چند ستونی - نسخه قابل چاپ

کد:
Option Explicit

Private 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

Private Const MF_MENUBARBREAK = &H20& ' columns with a separator line

Private Const MF_MENUBREAK = &H40& ' columns w/o a separator line

Private Const MF_STRING = &H0&

Private Const MF_HELP = &H4000&

Private Const MFS_DEFAULT = &H1000&

Private Const MIIM_ID = &H2

Private Const MIIM_SUBMENU = &H4

Private Const MIIM_TYPE = &H10

Private Const MIIM_DATA = &H20

Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GetMenuItemInfo Lib "user32" _

Alias "GetMenuItemInfoA" _

(ByVal hMenu As Long, ByVal un As Long, ByVal B As Boolean, _

lpMenuItemInfo As MENUITEMINFO) As Long

Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" _

(ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, _

lpcMenuItemInfo As MENUITEMINFO) As Long

Private Declare Function DrawMenuBar Lib "user32" _

(ByVal hwnd As Long) As Long

Private Declare Function GetSubMenu Lib "user32" _

(ByVal hMenu As Long, ByVal nPos As Long) As Long

Private Sub Command1_Click()

' Splitting a menu here demonstrates that this can be done dynamically.

Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long

Dim BuffStr As String * 80 ' Define as largest possible menu text.

hMenu = GetMenu(Me.hwnd) ' retrieve menu handle.

BuffStr = Space(80)

With mnuItemInfo ' Initialize the UDT.

.cbSize = Len(mnuItemInfo) ' 44

.dwTypeData = BuffStr & Chr(0)

.fType = MF_STRING

.cch = Len(mnuItemInfo.dwTypeData) ' 80

.fState = MFS_DEFAULT

.fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU

End With

' Use item break point position for the '3' below (zero-based list).

hSubMenu = GetSubMenu(hMenu, 0)

If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then

MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , _

"Error"

Else

mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBARBREAK

If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then

MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , _

"Error"

End If

End If

DrawMenuBar (Me.hwnd) ' Repaint top level Menu.

End Sub

Private Sub Form_Load()

' This works for either an API-created menu or a native VB Menu.

Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long

Dim BuffStr As String * 80 ' Define as largest possible menu text.

hMenu = GetMenu(Me.hwnd) ' Retrieve menu handle.

BuffStr = Space(80)

With mnuItemInfo ' Initialize the UDT

.cbSize = Len(mnuItemInfo) ' 44

.dwTypeData = BuffStr & Chr(0)

.fType = MF_STRING

.cch = Len(mnuItemInfo.dwTypeData) ' 80

.fState = MFS_DEFAULT

.fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU

End With

' Use item break point position for the '3' below (zero-based list).

hSubMenu = GetSubMenu(hMenu, 1)

If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then

MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , _

"Error"

Else

mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBREAK

If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then

MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , _

"Error"

End If

End If

DrawMenuBar (Me.hwnd) ' Repaint top level Menu.

End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _

X As Single, Y As Single)

If Button = vbRightButton Then

PopupMenu saf ' Use the name of one of your menus.

End If

End Sub