modmenusxp.bas

很好一套库存管理

        Set VisibleMenus = New Collection
    Case WM_MDIACTIVATE
        'Debug.Print "MDI child created"
        ' MDI children get their menus subclassed to the parent by Windows
        ' We set the class's parentform value to the MDI's parent & when
        ' submenus are processed, they are redirected to the parent
        ' The ChildStatus is set to clean out the parent's class when the
        ' child window is closed
        ' The GetSetMDIchildSysMenu command is run to store the system menu
        ' with the parent form. When the child is maximized its system menu
        ' shows up on the parent form & needs to be compared so the class
        ' doesn't draw for the system menu which it can't do!
        MenuData(ActiveHwnd).ParentForm = GetParent(GetParent(hwnd))
        MenuData(CStr(MenuData(ActiveHwnd).ParentForm)).GetSetMDIchildSysMenu GetSystemMenu(hwnd, False), True
        MenuData(ActiveHwnd).ChildStatus = 1
    Case WM_MEASUREITEM
        'Debug.Print "measuring"
        ' occurs after menu initialized & before drawing takes place
        ' send to drawing routine to measure the height/width of the menu panel
        ' If we measured it, don't let windows measure it again
        If CustomDrawMenu(wMsg, lParam, wParam) = True Then Exit Function
    Case WM_INITMENUPOPUP   ', WM_INITMENU
        If wParam = 0 Then Err.Raise 5  ' ignore these messages & pass them thru
        'Debug.Print "Popup starts"
        ' Occurs each time a menu is about to be displayed, wMsg is the handle
        ' Send flag to drawing routine to allow icons to be redrawn
        CustomDrawMenu wMsg, 0, 0
        GetMenuMetrics wParam    ' get measurements for menu items
        ' allow message to pass to the destintation
    Case WM_DRAWITEM
        'Debug.Print "drawing"
        ' sent numerous times, just about every time the mouse moves
        ' over the menu. Send flag to redraw menu if needed
        ' If we drew it, don't let windows redraw it
        If CustomDrawMenu(wMsg, lParam, wParam) = True Then Exit Function
    Case WM_EXITMENULOOP
        'Debug.Print "exiting loop"
        ' When a menu is clicked on or closed, we remove the collection of submenus
        ' so they can be redrawn again as needed
        Set VisibleMenus = Nothing
    Case WM_ENTERIDLE
        'Debug.Print "Popup ends"
        ' occurs after the entire menu has been measured & displayed
        ' at least once. Send flag to not redraw icons
        CustomDrawMenu wMsg, 0, 0
End Select
SendMessageAsIs:
MsgProc = CallWindowProc(MenuData(ActiveHwnd).OldWinProc, hwnd, wMsg, wParam, lParam)
End Function

Public Function GetMenuIconID(Menu_Caption As String) As Long
' =====================================================================
'   Returns the icon assigned in the menu caption as a long value
'   Example: {IMG:9}&Open would return 9
'   Note: Not used in any modules here, but provided for programmer use
'         if needed in their applications
' =====================================================================
Dim i As Integer
On Error GoTo NoIcon
i = InStr(Menu_Caption, "{IMG:")
If i Then
    GetMenuIconID = VAL(Mid$(Menu_Caption, InStr(Menu_Caption, ":") + 1))
End If
Exit Function
NoIcon:
GetMenuIconID = 0
End Function

Private Sub GetMenuMetrics(hSubMenu As Long)
' =====================================================================
' Routine gets the meaurements of the submenus & their submenus,
'   their checked status, enabled status,
'   control keys, icon index, etc
' =====================================================================

Dim lMenus As Long, hWndRedirect As String
Dim Looper As Long, meDC As Long, lmnuID As Long, sysMenuLoc As Long
Dim mII As MENUITEMINFO, mI() As Byte
Dim tRect As RECT, lMetrics(0 To 10) As Long
Dim sCaption As String, sBarCaption As String
Dim sHotKey As String, bTabOffset As Boolean
Dim IconID As Integer, iTransparency As Integer
Dim bSetHotKeyOffset As Boolean, bNewItem As Boolean
Dim bHasIcon As Boolean, bRecalcSideBar As Long
Dim iSeparator As Integer, bSpecialSeparator As Boolean

On Error Resume Next
If MenuData(ActiveHwnd).GetSetMDIchildSysMenu(hSubMenu, False) = True Then Exit Sub
If Not VisibleMenus Is Nothing Then
    ' here we track which submenus are currently visible so we don't
    ' re-process data which isn't needed until after the submenu is closed
    lMenus = VisibleMenus(CStr(hSubMenu))
    If lMenus Then Exit Sub
End If
On Error GoTo 0
meDC = GetDC(CLng(ActiveHwnd))
hWndRedirect = MenuData(ActiveHwnd).ParentForm
' Get the ID for the next submenu item
lMenus = GetMenuItemCount(hSubMenu)
lSubMenu = hSubMenu
modDrawing.TargethDC = meDC
DetermineOS
With MenuData(hWndRedirect)         ' class for this form
    For Looper = 0 To lMenus - 1    ' loop thru each subitem
        ' get the submenu item
        bSpecialSeparator = False
        iSeparator = 0: iTransparency = 0
        sHotKey = ""
        ' now set some flags & stuff to return the caption,  checked & enabled status
        ' by referencing the dwTypeData as a byte array vs long or string,
        ' we bypass the VB crash that happens on Win98 & XP & probably others
        ReDim mI(0 To 255)
        mII.cbSize = Len(mII)
        mII.fMask = &H10 Or &H1 Or &H2
        mII.fType = 0
        mII.dwTypeData = VarPtr(mI(0))
        mII.cch = UBound(mI)
        ' get the submenu item information
        GetMenuItemInfo hSubMenu, Looper, True, mII
        'Debug.Print lmnuID; "has submenus"; mII.hSubMenu
        If Abs(mII.wID) = 4096 Or mII.wID = -1 Then Exit Sub
        lmnuID = mII.wID
        bNewItem = .SetMenuID(lmnuID, hSubMenu, False, True)
        sCaption = Left$(StrConv(mI, vbUnicode), mII.cch)
        If Len(Replace$(sCaption, Chr$(0), "")) = 0 Then sCaption = .OriginalCaption
        If Left(UCase(sCaption), 9) = "{SIDEBAR:" Then sBarCaption = sCaption
        'Debug.Print hWndRedirect; hSubMenu; lmnuID; " Caption: "; sCaption
        If .OriginalCaption = sCaption And bNewItem = False Then
            ' here we can get cached info vs reprocessing it again
            lMetrics(1) = lMetrics(1) + .ItemHeight
            lMetrics(10) = .ItemWidth
            If LoWord(lMetrics(10)) > lMetrics(0) Then lMetrics(0) = LoWord(lMetrics(10))
            If HiWord(lMetrics(10)) > lMetrics(9) Then lMetrics(9) = HiWord(lMetrics(10))
            lMetrics(4) = .SideBarWidth
            If .Icon <> 0 Then bHasIcon = True
            If InStr(sCaption, Chr$(9)) Then bTabOffset = True
            'Debug.Print "reading existing " & Looper + 1, sCaption
        Else
            bNewItem = True
            If Len(sBarCaption) > 0 And bRecalcSideBar = 0 Then bRecalcSideBar = lmnuID
            .OriginalCaption = sCaption
            .Status = 0
            ' new item or change in caption, let's get some measurements
            ' first extract the caption, controlkeys & icon
            If InStr(sCaption, Chr$(9)) Then bTabOffset = True
            ' when Win98 encounters a hotkey above, it automatically
            ' increases the menu panel width. We need to note that
            ' so we can decrease the panel widh appropriately and
            ' offset the automatic increase. This helps prevent extra
            ' wide menu panels
            If Left(UCase(sCaption), 9) = "{SIDEBAR:" Then
                iSeparator = 1
                .Status = .Status Or 16
                .ItemHeight = 0
                .ItemWidth = 0
                .Icon = 0
            Else
                'Debug.Print "Caption "; sCaption
                FindImageAndHotKey hWndRedirect, sCaption, iTransparency, sHotKey, IconID
                Debug.Print "iconid="; IconID
                ' identify whether or not this is a separator
                iSeparator = Abs(CInt(Len(sCaption) = 0 Or Left$(sCaption, 1) = "-"))
                If iSeparator = 0 Then iSeparator = Abs(CInt(mII.fType And MF_SEPARATOR) = MF_SEPARATOR)
                If iSeparator Then IconID = 0   ' no pictures on separator bars!
                If Len(sCaption) > 0 And iSeparator = 1 Then
                    ' separator bar with text
                    ' calculate entire caption & set a few flags
                    sCaption = Mid$(sCaption, 2) & "  " & sHotKey
                    bSpecialSeparator = True
                    sHotKey = ""                ' not used for separators
                End If
                ' start saving the information
                .Caption = Trim$(sCaption & " " & sHotKey)
                .Icon = IconID
                .Status = .Status Or iTransparency * 4
                .Status = .Status Or iSeparator * 2
                If IconID Then bHasIcon = True
                SetMenuFont True, , bSpecialSeparator    ' add smaller menu font
                ' measure the caption width to help identify how wide
                ' the menu panel should be (greatest width of all submenu items)
                DrawText meDC, sCaption, Len(sCaption), tRect, DT_CALCRECT Or DT_LEFT Or DT_SINGLELINE Or DT_NOCLIP
                ' keep track of the largest width, this will be used to
                ' left align control keys for the entire panel
                If tRect.Right > lMetrics(0) Then lMetrics(0) = tRect.Right
                lMetrics(10) = tRect.Right
                If iSeparator = 0 Or bSpecialSeparator = True Then
                    ' set min height text menu items to match 16x16 icon height
                    If tRect.Bottom < 10 And bSpecialSeparator = False Then tRect.Bottom = 10
                    tRect.Bottom = tRect.Bottom + 6
                Else
                    tRect.Bottom = 5    ' make default separators 0 height
                End If
                ' store the height of the caption text
                .ItemHeight = tRect.Bottom
                lMetrics(1) = lMetrics(1) + tRect.Bottom
                SetMenuFont False
                If Len(sHotKey) Then
                    .HotKeyPos = Len(sCaption) + 1
                    ' now do the same for the hotkey
                    DrawText meDC, Trim(sHotKey), Len(Trim(sHotKey)), tRect, DT_CALCRECT Or DT_LEFT Or DT_NOCLIP Or DT_SINGLELINE
                    ' keep track of the widest control key text
                    ' this is used w/widest caption to determine overall
                    ' panel width including icons & checkmarks. Add 12 pixels for
                    ' buffer between end of caption & beginning of control key
                    If tRect.Right > lMetrics(9) Then lMetrics(9) = tRect.Right
                    .ItemWidth = MakeLong(CInt(lMetrics(10)), CInt(tRect.Right))
                Else
                    .ItemWidth = MakeLong(CInt(lMetrics(10)), 0)
                End If
            End If
        End If
        ' we ensure the item is drawn by us
        ' force a separator status if appropriate
        mII.fMask = 0
        If mII.fType = MF_SEPARATOR Or iSeparator = 1 Then
           mII.fType = MF_SEPARATOR Or MF_OWNERDRAW
        Else    ' otherwise it's normal
           mII.fType = mII.fType Or MF_OWNERDRAW
        End If
        mII.fMask = mII.fMask Or MIIM_TYPE Or MIIM_DATA   ' reset mask
        ' save updates to allow us to draw the menu item
        SetMenuItemInfo hSubMenu, Looper, True, mII
    Next
    If Looper > 0 Then  ' menu items processed
        If bRecalcSideBar = 0 Then  ' sidebar menu id
            ' if no sidebar was processed, then check the overall panel height
            ' if it changed, we need to reprocess the sidebar again since
            ' the graphics & text are centered in the panel
            If .PanelHeight <> lMetrics(1) And .SideBarItem <> 0 Then bRecalcSideBar = lmnuID
        End If
        lMetrics(3) = 5 + Abs(CInt(bHasIcon)) * 18
        lMetrics(2) = lMetrics(0) + 12
        lMetrics(0) = lMetrics(2) + lMetrics(9) + lMetrics(3) + lMetrics(4) + CInt(bTabOffset) * iTabOffset
        If bRecalcSideBar Then
            .SetMenuID bRecalcSideBar, hSubMenu, False, False
            ReturnSideBarInfo hWndRedirect, sBarCaption, lMetrics(), meDC
        End If
        .UpdatePanelID lMetrics(), sBarCaption, (bRecalcSideBar = 0)
    End If
End With
If Not VisibleMenus Is Nothing Then VisibleMenus.Add 1, (CStr(hSubMenu))
' now we replace the default font & release the form's DC
SetMenuFont False, meDC
ReleaseDC CLng(ActiveHwnd), meDC
Erase lMetrics
Erase mI
End Sub

Private Sub FindImageAndHotKey(hWndRedirect As String, sKey As String, imgTransparency As Integer, sAccel As String, imgIndex As Integer)
' =====================================================================
' This routine extracts the imagelist refrence and resets it if the
' image doesn't exist or not imagelist was provided
' =====================================================================
On Error Resume Next
Dim i As Integer, sSpecial As String, sHeader As String
imgIndex = 0
imgTransparency = 0
If Left$(UCase(sKey), 5) = "{IMG:" Then
    i = InStr(sKey, "}")
    If i Then
        sHeader = UCase(Left$(sKey, i))
        sKey = Mid$(sKey, i + 1)
        ' extract the image index
        imgIndex = VAL(Mid$(sHeader, 6))
        ' if the value<1 or >nr of images, then reset it to zero
        Debug.Print "icon count="; MenuData(hWndRedirect).TotalIcons