modmenusxp.bas

很好一套库存管理

Attribute VB_Name = "modMenus"
Option Explicit

'                              IMPORTANT
'======================================================================
' Set the following constant to TRUE if you need to debug your code]
' When set to False, stopping your code will crash VB
'======================================================================
Public Const bAmDebugging As Boolean = False
' =====================================================================
' Go to end of module (ReadMe) for details on how to use this module
' =====================================================================

' Types used to retrieve current menu item information
Public Type MenuDataInformation    ' information to store menu data
    ItemHeight As Integer       ' submenu item height
    ItemWidth As Long           ' pixel width of caption and hotkey
    Icon As Long                ' icon index
    HotKeyPos As Integer        ' instr position for hotkey
    Status As Byte              ' 2=Separator, 4=ForceTransparency 8=ForceNoTransparency
    Caption As String           ' Caption
    OriginalCaption As String   ' used to check for updated menu captions
    Parent As Long              ' submenu ID
    ID As Long                  ' menu item ID
End Type
Public Type PanelDataInformation
    Height As Long          ' height of the menu panel
    Width As Long           ' width of the menu panel
    HKeyPos As Long         ' left edge for all hot keys
    SideBar As Long         ' width of SideBar (default is 32)
    SideBarXY As Long       ' X,Y coords of image/text within sidebar
    PanelIcon As Long       ' does 1 or more menu items have an icon
    Status As Byte          ' icon or bitmap, 0 for text
    Caption As String       ' Text, unless image is used instead
    FColor As Long          ' Sidebar text fore color
    BColor As Long          ' Sidebar back color
    SBarIcon As Long        ' icon/bitmap ID for sidebar, Font ID for text
    ID As Long
End Type
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 Long 'String
     cch As Long
End Type
Private Type MEASUREITEMSTRUCT
     CtlType As Long
     CtlID As Long
     ItemId As Long
     ItemWidth As Long
     ItemHeight As Long
     ItemData As Long
End Type
Private 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
Private Type OSVERSIONINFO          ' used to help identify operating system
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Type ICONINFO
    fIcon As Long
    xHotSpot As Long
    yHotSpot As Long
    hbmMask As Long
    hbmColor As Long
End Type

' APIs needed to retrieve menu information
Private Declare Function WindowFromDC Lib "user32" (ByVal hDC As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetMenu 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 Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) 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 GetMenuItemInfo Lib "user32" Alias _
     "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, _
     ByVal byPosition As Long, lpMenuItemInfo As MENUITEMINFO) As Boolean
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 Sub CopyMemory Lib "kernel32" Alias _
     "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
' Subclassing APIs & stuff
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
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
     (ByVal hwnd As Long, ByVal nIndex As Long, _
     ByVal dwNewLong As Long) As Long
Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hDC As Long, ByVal iMode As Long) As Long
Private Declare Function IsZoomed Lib "user32" (ByVal hwnd As Long) As Long
' Subclassing & Windows Message Constants
Public Const GWL_WNDPROC = (-4)
Private Const WM_DRAWITEM = &H2B
Private Const WM_MEASUREITEM = &H2C
Private Const WM_INITMENU = &H116
Private Const WM_INITMENUPOPUP = &H117
Private Const WM_ENTERIDLE = &H121
Private Const WM_MDICREATE = &H220
Private Const WM_MDIACTIVATE = &H222
Private Const WM_ENTERMENULOOP = &H211
Private Const WM_EXITMENULOOP = &H212

Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

' Menu Constants
Private Const MF_BYCOMMAND = &H0
Private Const MF_BYPOSITION = &H400
Private Const MF_OWNERDRAW = &H100
Private Const MF_SEPARATOR = &H800
Private Const MFT_SEPARATOR = MF_SEPARATOR
Private Const ODS_SELECTED = &H1
Private Const ODT_MENU = 1
Private Const MIIM_TYPE = &H10
Private Const MIIM_DATA = &H20
Private Const MIIM_SUBMENU = &H4

Private MenuData As Collection  ' Collection of clsMyMenu objects
Private ActiveHwnd As String    ' Index to focused form
Private iTabOffset As Integer   ' See DetermineOS function
Private lSubMenu As Long
Private lMDIchildClosed As Long
Private VisibleMenus As Collection

Public Sub SetMenus(Form_hWnd As Long, Optional MenuImageList As Control)
' =====================================================================
' This is the routine that will subclass form's menu & gather initial
' menu data
' =====================================================================
If bAmDebugging Then Exit Sub
' here we set the collection index & see if it's already been subclassed
Dim lMenus As Long, Looper As Integer
On Error Resume Next
If GetFormHandle(Form_hWnd) = -1 Then Exit Sub

lMenus = MenuData(CStr(Form_hWnd)).MainMenuID
If Err Then ' then new form to subclass
   ' Initialize a collection of classes if needed
   If MenuData Is Nothing Then Set MenuData = New Collection
   Dim NewMenuData As New clsMyMenu
   ' save the ImageList & Handle to the form's menu
   With NewMenuData
        .SetImageViewer MenuImageList
        .MainMenuID = GetMenu(Form_hWnd)
        ' used to redirect MDI children to parent for submenu info (see MsgProc:MDIactivate)
        .ParentForm = Form_hWnd
    End With
    ' Add the class to the class collection & remove the instance of the new class
    MenuData.Add NewMenuData, CStr(Form_hWnd)
    Set NewMenuData = Nothing
Else
    ' form is already subclassed, do nothing!
    Exit Sub
End If
Err.Clear
ActiveHwnd = CStr(Form_hWnd)    ' set collection index to current form
CleanMDIchildMenus
lMenus = GetMenuItemCount(MenuData(ActiveHwnd).MainMenuID)
For Looper = 0 To lMenus - 1
    'GetMenuMetrics GetSubMenu(MenuData(ActiveHwnd).MainMenuID, Looper)
Next
SetFreeWindow True              ' hook the window so we can intercept windows messages
End Sub

Public Sub ReleaseMenus(hwnd As Long)
' =====================================================================
' Sub prepares for Forms unloading
' This must be placed in the forms Unload event in order to
' release memory & prevent crash of program
' =====================================================================

If MenuData Is Nothing Then Exit Sub
On Error GoTo ByPassRelease
ActiveHwnd = CStr(hwnd)     ' set current index
SetFreeWindow False         ' unhook the window
On Error Resume Next
If MenuData(ActiveHwnd).ChildStatus = 1 Then
    lMDIchildClosed = MenuData(ActiveHwnd).ParentForm
End If
' remove references to that form's class & ultimately unload the class
MenuData.Remove ActiveHwnd
If MenuData.Count = 0 Then
    ' here we clean up a little when all subclassed forms have been unloaded
    Set MenuData = Nothing      ' erase the collection of classes which will unload the class
    DestroyMenuFont             ' get rid of memory font
    modDrawing.TargethDC = 0    ' get rid of refrence in that module
End If
ByPassRelease:
End Sub

Private Sub CleanMDIchildMenus()
' reset parent's menu items (see that routine for remarks)
If lMDIchildClosed = 0 Then Exit Sub
Dim Looper As Long, mMenu As Long, mII As MENUITEMINFO
mII.cbSize = Len(mII)
mII.fMask = &H1 Or &H2
mII.fType = 0
On Error Resume Next
With MenuData(CStr(lMDIchildClosed))
    For Looper = .PanelIDcount To 1 Step -1
        mMenu = .GetPanelID(Looper)
        If GetMenuItemCount(mMenu) < 0 Then .PurgeObsoleteMenus mMenu
    Next
End With
lMDIchildClosed = 0
End Sub

Public Function MsgProc(ByVal hwnd As Long, ByVal wMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long

' =====================================================================
' Here we determine which messages will be processed, relayed or
' skipped. Basically, we send anything thru unless we are measuring
' or drawing an item.
' =====================================================================

On Error GoTo SendMessageAsIs
' the following is a tell-tale sign of a system menu
If lParam = &H10000 Then Err.Raise 5
ActiveHwnd = CStr(hwnd) ' ensure index to current form is set
Select Case wMsg
    Case WM_ENTERMENULOOP
        'Debug.Print "entering loop"
        ' When a menu is activated, no changes can be made to the captions, enabled status, etc
        ' So we will save each submenu as it is opened and read the info only once,
        ' this will prevent unnecessary reads each time the submenu is displayed