modmenusxp.bas

很好一套库存管理

'Get the info about our image
If GetObject(vBarInfo(10), Len(imgInfo), imgInfo) = 0 Then 'And vControl Is Nothing Then
    GetIconInfo vBarInfo(10), picInfo
    If picInfo.xHotSpot = 0 Or picInfo.yHotSpot = 0 Then
        'if the image passed was a handle vs control and not a bitmap
        ' sidebar fails
        Debug.Print "Sidebar failed image is not a bitmap or icon type"
        vBarInfo(10) = 0
        vBarInfo(4) = 0
        Return
    End If
    vBarInfo(9) = 16
    vBarInfo(5) = picInfo.xHotSpot
    vBarInfo(8) = picInfo.yHotSpot
Else
    vBarInfo(9) = 8
    vBarInfo(5) = imgInfo.bmWidth
    vBarInfo(8) = imgInfo.bmHeight
End If
Err.Clear
If vBarInfo(6) = -2 Then
    Dim picIcon As PictureBox
    Forms(formID).Controls.Add "VB.PictureBox", "pic___Ic_on_s", Forms(formID)
    With Forms(formID).Controls("pic___Ic_on_s")
        .Visible = False
        .AutoRedraw = True
        If vBarInfo(6) = -2 Then
            If vBarInfo(9) = 8 Then i = 4 Else i = 3
            ' draw the image to the picturebox
            If DrawState(.hDC, 0, 0, vBarInfo(10), 0, 0, 0, 0, 0, CLng(i)) = 0 Then
                ' drawing failed, try again with differnt picture type
                If i = 4 Then i = 3 Else i = 4
                DrawState .hDC, 0, 0, vBarInfo(10), 0, 0, 0, 0, 0, CLng(i)
            End If
            ' get the mask color
            vBarInfo(6) = GetPixel(.hDC, 0, 0)
        End If
    End With
    Forms(formID).Controls.Remove "pic___Ic_on_s"
End If
Return
End Sub

Private Sub SetFreeWindow(bSet As Boolean)
' =====================================================================
' This routine hooks or unhooks a window & is used when
' menus are first set and when a form closes
' =====================================================================

If MenuData(ActiveHwnd).OldWinProc = 0 And bSet = True Then
    ' hook only if window not already hooked
    MenuData(ActiveHwnd).OldWinProc = SetWindowLong(CLng(ActiveHwnd), GWL_WNDPROC, AddressOf MsgProc)
Else
    If MenuData(ActiveHwnd).OldWinProc <> 0 And bSet = False Then
        ' hook only if window was already hooked
         SetWindowLong CLng(ActiveHwnd), GWL_WNDPROC, MenuData(ActiveHwnd).OldWinProc
         MenuData(ActiveHwnd).OldWinProc = 0
    End If
End If
End Sub

Private Function CustomDrawMenu(wMsg As Long, lParam As Long, wParam As Long) As Boolean
' =====================================================================
' Here we simply measure & draw menu items based on settings saved
' in the form's related class
' =====================================================================

Dim IsSep As Boolean, hWndRedirect As String
Static bDrawIcon As Boolean, bDrawPanel As Boolean, bGetPanelData As Boolean
Static lOffsets(0 To 2) As Long, lLastSubMenu As Long
' MDI children menus are subclassed to parent by Windows
' However, if the child isn't maximized in the MDI parent, then the menus are
' not subclassed (pain in the neck until this was figured out & re-thought)
' To work around this & prevent the submenus from being stored in both the parent
' and child classes, I redirect the actions to the parent via the GetMenuMetrics sub
' regardless whether or not the child is maximized
' Since each menu drawn is now stored the parent class, we redirect to the routine to
' get the info from the parent. If the form is the MDI parent or is a non-MDI form,
' then the ParentForm property is the same as the form's actual handle
hWndRedirect = MenuData(ActiveHwnd).ParentForm ' here we set this flag.

Select Case wMsg
Case WM_INITMENUPOPUP
    ' menu is about to be displayed, set flag to allow drawing of icons
    bDrawIcon = True: bDrawPanel = True: bGetPanelData = True
    lLastSubMenu = 0
Case WM_DRAWITEM
    Dim DrawInfo As DRAWITEMSTRUCT
    Dim IsSideBar As Boolean
    Dim hBR As Long, hOldBr As Long, hChkBr As Long
    Dim hPen As Long, hOldPen As Long, lTextColor As Long
    Dim tRect As RECT
    Dim iRectOffset As Integer, iSBoffset As Integer
    Dim sAccelKey As String, sCaption As String
    Dim bMenuItemDisabled As Boolean, bMenuItemChecked As Boolean
    Dim bSelected As Boolean, bHasIcon As Boolean
    
    'Get DRAWINFOSTRUCT which gives us sizes & indexes
    Call CopyMemory(DrawInfo, ByVal lParam, LenB(DrawInfo))
    ' only process menu items, other windows items send above message
    ' and we don't want to interfere with those. Also if we didn't
    ' process it, we don't touch it
    lSubMenu = DrawInfo.hwndItem
    If MenuData(hWndRedirect).SetMenuID(DrawInfo.ItemId, DrawInfo.hwndItem, False, False) = False Then Exit Function
    If DrawInfo.CtlType <> ODT_MENU Then Exit Function
    CustomDrawMenu = True
    IsSideBar = CBool((MenuData(hWndRedirect).Status And 16) = 16)
    If (IsSideBar = True And bDrawPanel = False) Then Exit Function
    IsSep = (MenuData(hWndRedirect).Status And 2) = 2 And IsSideBar = False
    ' get the checked & enabled status
    bMenuItemDisabled = CBool((DrawInfo.itemState And 6) = 6 Or (DrawInfo.itemState And 7) = 7)
    ' don't continue the process if the disabled item or separator
    ' was already drawn, no need to redraw it again - it doesn't change
    If bDrawIcon = False And (bMenuItemDisabled = True Or IsSep = True) Then Exit Function
    bMenuItemChecked = CBool((DrawInfo.itemState And 8) = 8 Or (DrawInfo.itemState And 9) = 9)
    ' set a reference in the drawing module to this menu's DC & set the font
    modDrawing.TargethDC = DrawInfo.hDC
    If bDrawPanel = True Or lLastSubMenu <> DrawInfo.hwndItem Then
        Dim pData(0 To 10) As Long
        MenuData(hWndRedirect).GetPanelInformation pData(), sCaption
        lOffsets(2) = pData(3)
        If lOffsets(2) Then lOffsets(2) = lOffsets(2) + 5
        lOffsets(1) = pData(4)
        If pData(4) Then lOffsets(1) = lOffsets(1) + 3
        lOffsets(0) = lOffsets(1) + lOffsets(2)
        If bDrawPanel = True Then
            If pData(10) <> 0 Then
                Debug.Print "panel xy:"; pData(4), pData(1)
                tRect.Bottom = pData(1)
                tRect.Right = pData(4)
                hBR = CreateSolidBrush(pData(6))
                hPen = GetPen(1, pData(6))
                hOldPen = SelectObject(DrawInfo.hDC, hPen)
                hOldBr = SelectObject(DrawInfo.hDC, hBR)
                DrawRect 0, 0, tRect.Right, tRect.Bottom
                SelectObject DrawInfo.hDC, hOldBr
                DeleteObject hBR
                SelectObject DrawInfo.hDC, hOldPen
                DeleteObject hPen
                pData(8) = CLng(HiWord(pData(5)))
                pData(5) = CLng(LoWord(pData(5)))
                If (pData(9) And 2) = 2 Then
                    modDrawing.TargethDC = DrawInfo.hDC
                    DrawMenuIcon pData(10), Abs(CInt((pData(9) Or 16) = 16) * 2) + 1, _
                        tRect, False, , 2, CInt(pData(5)), CInt(pData(8)), LoWord(pData(7)), HiWord(pData(7)), pData(6)
                Else
                    SetBkMode DrawInfo.hDC, NEWTRANSPARENT
                    DetermineOS DrawInfo.hDC
                    If (pData(9) And 32) = 32 Then DoGradientBkg pData(6), tRect, CLng(hWndRedirect)
                    SetMenuFont True, , , pData(10)
                    tRect.Left = (pData(4) - pData(5)) \ 2
                    tRect.Top = (pData(1) - pData(8)) \ 2 + pData(8)
                    SetTextColor DrawInfo.hDC, pData(7)
                    DrawText DrawInfo.hDC, sCaption, Len(sCaption), tRect, DT_LEFT Or DT_NOCLIP Or DT_SINGLELINE Or &H800
                    SetMenuFont False
                End If
            End If
        End If
        bDrawPanel = False
        lLastSubMenu = DrawInfo.hwndItem
        Erase pData
    End If
    If IsSideBar Then
        CustomDrawMenu = True
        Exit Function
    End If
    SetMenuFont True
    ' determine if this item is focused or not which also determines
    ' what colors we use when we are drawing
    bSelected = (DrawInfo.itemState And ODS_SELECTED) = ODS_SELECTED
    ' Now let's set some colors to draw with
    With DrawInfo
        If bSelected = True And bMenuItemDisabled = False And IsSep = False Then
             hBR = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))
             hPen = GetPen(1, GetSysColor(COLOR_HIGHLIGHT))
             lTextColor = GetSysColor(COLOR_HIGHLIGHTTEXT)
        Else
             hBR = CreateSolidBrush(GetSysColor(COLOR_MENU))
             hPen = GetPen(1, GetSysColor(COLOR_MENU))
             If bMenuItemDisabled Or IsSep = True Then
                  lTextColor = GetSysColor(COLOR_HIGHLIGHTTEXT)
             Else
                  lTextColor = GetSysColor(COLOR_MENUTEXT)
             End If
        End If
        If bMenuItemDisabled = True Then
             ' for checked & disabled items, we use default back color
             hChkBr = CreateSolidBrush(GetSysColor(COLOR_MENU))
        Else
            ' here we set the back color of a depressed button
            hChkBr = CreateSolidBrush(GetSysColor(COLOR_BTNLIGHT))
        End If
        'Select our new, correctly colored objects:
        hOldBr = SelectObject(.hDC, hBR)
        hOldPen = SelectObject(.hDC, hPen)
        'Do we have a separator bar?
        bHasIcon = False
        sCaption = MenuData(hWndRedirect).Caption
        If Not IsSep Then
        ' Ok, does this item have an icon?
        ' Here we do one more extra check in case the ImageViewer
        ' is no longer available or has no images (then handle is 0)
        ' we also set the offset for highlighting rectangle's left
        ' edge so it doesn't highlight icons
            If MenuData(hWndRedirect).ImageViewer > 0 And _
              MenuData(hWndRedirect).Icon > 0 Then
                bHasIcon = True
                iRectOffset = lOffsets(0) - 2
            Else
                'If bMenuItemChecked Then
                '    iRectOffset = lOffsets(0) - 2
                'Else
                    iRectOffset = lOffsets(1)
                'End If
            End If
            'Draw the highlighting rectangle
            DrawRect .rcItem.Left + iRectOffset, .rcItem.Top, .rcItem.Right, .rcItem.Bottom
            'Print the menu item's text
            If MenuData(hWndRedirect).HotKeyPos Then
                ' we have a control key, so identify it & its left edge
                sAccelKey = Mid$(sCaption, MenuData(hWndRedirect).HotKeyPos)
                sCaption = Left$(sCaption, InStr(sCaption, sAccelKey))
            End If
            ' send the caption, control key, icon offset, etc to be printed
            tRect = .rcItem
            DrawCaption .rcItem.Left + lOffsets(0), .rcItem.Top + 3, _
                tRect, sCaption, sAccelKey, MenuData(hWndRedirect).HotKeyEdge, lTextColor
            If bMenuItemDisabled Then   ' add the engraved affect
                tRect = .rcItem         ' get starting rectangle &
                OffsetRect tRect, -1, -1 ' offset by 1 top & left
                ' print text again with offsets
                DrawCaption .rcItem.Left + lOffsets(0) - 1, .rcItem.Top + 2, _
                    tRect, sCaption, sAccelKey, MenuData(hWndRedirect).HotKeyEdge, _
                    GetSysColor(COLOR_GRAYTEXT)
            End If
            If bMenuItemChecked Then
                ' for checked items, since they can have icons, we do a few
                ' things different. We make the checked item appear in a sunken
                ' box and make the backcolor of the box lighter than normal
                SelectObject .hDC, hChkBr
                DrawRect lOffsets(1), .rcItem.Top, lOffsets(0) - 5, .rcItem.Bottom - 1
                ThreeDbox lOffsets(1) - 2, .rcItem.Top, lOffsets(0) - 3, .rcItem.Bottom - 2, True, True
                If bHasIcon = False Then
                    ' now if the checked item doesn't have an icon we draw a checkmark in the icons' place
                    DrawCheckMark .rcItem, IIf(bMenuItemDisabled, lTextColor, GetSysColor(COLOR_MENUTEXT)), False, lOffsets(1)
                    If bMenuItemDisabled Then DrawCheckMark .rcItem, GetSysColor(COLOR_GRAYTEXT), bMenuItemDisabled, lOffsets(1)
                End If
            End If
        End If
        'If the item has an icon, selected or not, disabled or not
        If bHasIcon = True Then
            If bDrawIcon = True Or bMenuItemChecked = True Then ' we are redrawing icons
                ' extract icon handle, type & transparency option
                Dim vIconDat() As Long
                MenuData(hWndRedirect).GetIconData vIconDat(), MenuData(hWndRedirect).Icon
                'set up the location to be drawn
                tRect.Left = 4 + lOffsets(1)
                tRect.Top = ((.rcItem.Bottom - .rcItem.Top) - 16) \ 2 + .rcItem.Top
                tRect.Right = tRect.Left + 16
                tRect.Bottom = tRect.Top + 16
                'send the icon information to be drawn
                DrawMenuIcon vIconDat(0), vIconDat(1), tRect, bMenuItemDisabled, True, vIconDat(2)
            End If
            SelectObject .hDC, hBR
            If bMenuItemDisabled = False And bMenuItemChecked = False Then
                ' here we draw or remove the 3D box around the icon