modmenusxp.bas

很好一套库存管理

        If imgIndex < 1 Or imgIndex > MenuData(hWndRedirect).TotalIcons Then
            imgIndex = 0
        Else    ' optional transparency flag
                ' Y=always use transparency
                ' N=never user transparency
                ' default: Icons never use transparency, Bitmaps always
            If InStr(sHeader, "|Y}") Then imgTransparency = 1
            If InStr(sHeader, "|N}") Then imgTransparency = 2
        End If
    End If
End If
' Parse the Caption & the Control Key
sAccel = ""
' First let's see if it's a menu builder supplied control key
' if so, it's easy to identify 'cause it is preceeded by a vbTab
i = InStr(sKey, Chr$(9))
If i Then       ' yep, menu builder supplied control key
    sAccel = Trim$(Mid$(sKey, i + 1))
    sKey = Trim$(Left$(sKey, i - 1))
Else
    ' user supplied control key, a little more difficult to find
    For i = 1 To 3  ' look for Ctrl, Alt & Shift combinations 1st
        If InStr(UCase(sKey), Choose(i, "CTRL+", "SHIFT+", "ALT+")) Then
            ' if found, then exit routine
            sAccel = Trim$(Mid$(sKey, InStr(UCase(sKey), Choose(i, "CTRL+", "SHIFT+", "ALT+"))))
            sKey = Trim$(Left$(sKey, InStr(UCase(sKey), Choose(i, "CTRL+", "SHIFT+", "ALT+")) - 1))
            Exit Sub
        End If
    Next
    For i = 1 To 15 ' look for F keys next
        If Right$(UCase(sKey), Len("F" & i)) = "F" & i Then
            ' if found, then exit routine
            sAccel = Trim$(Mid$(sKey, InStrRev(UCase(sKey), "F" & i)))
            sKey = Trim$(Left$(sKey, InStrRev(UCase(sKey), UCase(sAccel)) - 1))
            Exit Sub
        End If
    Next
    ' here we look for other types of hot keys, these can be customized
    ' as needed by following the logic below
    For i = 1 To 6
        ' hot key looking for, it will be preceded by a space and must
        ' be at end of caption, otherwise we ignore it
        sSpecial = Choose(i, " DEL", " INS", " HOME", " END", " PGUP", " PGDN")
        If Right$(UCase(sKey), Len(sSpecial)) = sSpecial Then
            sAccel = Trim$(Mid$(sKey, InStrRev(UCase(sKey), sSpecial)))
            sKey = Trim$(Left$(sKey, InStrRev(UCase(sKey), sSpecial) - 1))
            Exit For
        End If
    Next
End If
End Sub

Private Sub ReturnSideBarInfo(hWndRedirect As String, sBarInfo As String, vBarInfo() As Long, tDC As Long)
' =======================================================================
' This routine returns the sidebar information for the current submenu
' Basically we are parsing out the SIDEBAR caption
' =======================================================================

Dim i As Integer, sImgID As String
Dim lRatio As Single, sText As String
Dim bMetrics As Boolean, sTmp As String
Dim lFont As Long, lFontM As LOGFONT, hPrevFont As Long
Dim tRect As RECT
Dim imgInfo As BITMAP, picInfo As ICONINFO
Dim TempBMP As Long, ImageDC As Long, sbarType As Integer

' here we are just adding a delimeter at end of string to make parsing easier
If Right$(sBarInfo, 1) = "}" Then sBarInfo = Left$(sBarInfo, Len(sBarInfo) - 1)
sBarInfo = sBarInfo & "|"
' stripoff the SIDEBAR header
i = InStr(UCase(sBarInfo), "{SIDEBAR:")
sBarInfo = Mid$(sBarInfo, InStr(sBarInfo, ":") + 1)
' return the type of sidebar Image or Text
i = InStr(sBarInfo, "|")
' if the next line <> TEXT then we have an image handle or image control
sImgID = Left$(sBarInfo, i - 1)

On Error Resume Next
' can't leave memory fonts running around loose -- wasted memory
If MenuData(hWndRedirect).SideBarIsText = True And MenuData(hWndRedirect).SideBarItem <> 0 Then
    ' kill the previous font for this item, if any
    DeleteObject MenuData(hWndRedirect).SideBarItem
End If
vBarInfo(10) = 0                  ' reset to force no sidebar
' use with caution. Making width too small or too large
' may prevent menu from displaying or crash on memory
' suggest using between 32 & 64
If InStr(UCase(sBarInfo), "|WIDTH:") Then      ' width of the sidebar (user-provided)
    ' undocumented! this allows the sidebar width to be modified
    vBarInfo(4) = VAL(Mid$(sBarInfo, InStr(UCase(sBarInfo), "|WIDTH:") + 7))
Else
    ' however, 32 pixels wide seems to look the best
    vBarInfo(4) = 32                            ' default width of sidebars
End If
If IsNumeric(sImgID) Then         ' user is providing image handle vs a form picture object
    vBarInfo(10) = VAL(sImgID)    ' ref to picture if it exists
    sbarType = 2                  ' status: image sidebar
    vBarInfo(9) = 8               ' type default as bmp
Else
    If sImgID = "TEXT" Then
        sbarType = 4              ' status: text sidebar
        vBarInfo(9) = 0
        If InStr(UCase(sBarInfo), "|CAPTION:") Then
            sText = Mid$(sBarInfo, InStr(UCase(sBarInfo), "|CAPTION:") + 9)
            i = InStr(sText, "|")
            sText = Left$(sText, i - 1)
        End If
        sBarInfo = UCase(sBarInfo)  ' make it easier to parse
        If InStr(sBarInfo, "|FONT:") Then
            ' parse out the font
            sTmp = Mid$(sBarInfo, InStr(sBarInfo, "|FONT:") + 6)
            i = InStr(sTmp, "|")
            sTmp = Left$(sTmp, i - 1)
        Else
            sTmp = "Arial"     ' default if not provided
        End If
        lFontM.lfCharSet = 0   ' scalable only
        lFontM.lfFaceName = sTmp
        ' if user wants other font attributes, then make it so
        If InStr(sBarInfo, "|BOLD") Then sTmp = sTmp & " Bold"
        If InStr(sBarInfo, "|ITALIC") Then sTmp = sTmp & " Italic"
        lFontM.lfFaceName = sTmp & Chr$(0)
        If InStr(sBarInfo, "|UNDERLINE") Then lFontM.lfUnderline = 1
        ' if user wants a different fontsize then make it so
        If InStr(sBarInfo, "|FSIZE:") Then
            i = VAL(Mid$(sBarInfo, InStr(sBarInfo, "|FSIZE:") + 7))
            If i < 4 Then i = 12        ' min & max fonts
            If i > 24 Then i = 24
        Else
            i = 12  ' default font size
        End If
        Do
            ' here we are going to create fonts to see if it will
            ' fit in the sidebar, unfortunately we need to do this
            ' each time the menubar is initially displayed or resized because
            ' the sidebar height may have changed with adding/removing
            ' or making menu items invisible
            lFontM.lfHeight = (i * -20) / Screen.TwipsPerPixelY
            ' can't rotate the font before measuring it - per MSDN drawtext won't measure rotated fonts
            lFont = CreateFontIndirect(lFontM)    ' create the font without rotation
            hPrevFont = SelectObject(tDC, lFont)  ' load it into the DC
            ' see if it will fit in the sidebar
            DrawText tDC, sText, Len(sText), tRect, DT_CALCRECT Or DT_LEFT Or DT_SINGLELINE Or DT_NOCLIP Or &H800
            ' regardless we delete the font, cause we'll need to rotate it
            SelectObject tDC, hPrevFont
            DeleteObject lFont
            If tRect.Right > vBarInfo(1) Or tRect.Bottom > vBarInfo(4) Then
                ' font is too big, reduce it by 1 and try again
                i = i - 1
                If i < 4 Then Exit Do
            Else    ' font is ok, now we rotate it & save it
                lFontM.lfEscapement = 900
                lFont = CreateFontIndirect(lFontM)  ' create the font
                vBarInfo(10) = lFont                 ' save it
                vBarInfo(8) = tRect.Right           ' measurements
                vBarInfo(5) = tRect.Bottom
                Exit Do
            End If
        Loop
    Else
        ' here we have an image/picturebox control containing an image
        ' we need to extract the image handle
        Dim formID As Long, vControl As Control, bIsMDI As Boolean
        ' loop thru each open form to determine which is the active
        formID = GetFormHandle(CLng(hWndRedirect), bIsMDI)
        If formID > -1 Then
            sbarType = 2     'status: image sidebar
            ' let's see if the control passed is indexed
            If Right$(sImgID, 1) = ")" Then  ' indexed image
                i = InStrRev(sImgID, "(")
                sTmp = Left$(sImgID, i - 1)
                i = VAL(Mid$(sImgID, i + 1))
                If bIsMDI Then
                    If Forms(formID).ActiveForm Is Nothing Then
                        Set vControl = Forms(formID).Controls(sTmp).Item(i)
                    Else
                        ' when control is in an MDIs active form, we reference it this way
                        Set vControl = Forms(formID).ActiveForm.Controls(sTmp).Item(i)
                    End If
                Else
                    Set vControl = Forms(formID).Controls(sTmp).Item(i)
                End If
            Else
                If bIsMDI Then
                    If Forms(formID).ActiveForm Is Nothing Then
                        Set vControl = Forms(formID).Controls(sImgID)
                    Else
                        ' when control is in an MDIs active form, we reference it this way
                        Set vControl = Forms(formID).ActiveForm.Controls(sImgID)
                    End If
                Else
                    Set vControl = Forms(formID).Controls(sImgID)
                End If
            End If
            ' cache the picture handle & type
            vBarInfo(10) = vControl.Picture.Handle
            If vControl.Picture.Type = 3 Then vBarInfo(9) = 16 Else vBarInfo(9) = 8
            Set vControl = Nothing
        End If
    End If
End If
If vBarInfo(10) = 0 Then
    'failed retrieving sidebar information
    Debug.Print "Sidebar failed"
    vBarInfo(4) = 0
    Exit Sub
End If
sBarInfo = UCase(sBarInfo)  ' make it easier to parse
'ok, let's get the rest of the attributes
If InStr(sBarInfo, "|BCOLOR:") Then
    ' Background color for the sidebar
    Select Case Left$(Mid$(sBarInfo, InStr(sBarInfo, "|BCOLOR:") + 8), 4)
    Case "NONE": vBarInfo(6) = -1
    Case "BACK":    ' short for background
        ' if a text sidebar & background was provided we change to default
        If sbarType = 2 Then vBarInfo(6) = -2 Else vBarInfo(6) = -1
    Case Else   ' numeric background color -- use it
        vBarInfo(6) = VAL(Mid$(sBarInfo, InStr(sBarInfo, "|BCOLOR:") + 8))
    End Select
Else
    vBarInfo(6) = -1    ' default: use the menubar background color
End If
If vBarInfo(6) = -1 Then vBarInfo(6) = GetSysColor(COLOR_MENU)
If vBarInfo(10) Then
    If sbarType = 2 Then
        ' now if an image sidebar, we call subroutine for more attributes
        GoSub DrawPicture
        ' let's get the size of the image vs the size of the menu panel &
        ' either center or shrink the image to fit
        ' we will return the left offset, top offset & new image width, height
        If vBarInfo(5) > vBarInfo(4) Or vBarInfo(8) > vBarInfo(1) Then      ' image is larger than menu panel
            If vBarInfo(5) / vBarInfo(4) > vBarInfo(8) / vBarInfo(1) Then
                lRatio = vBarInfo(4) / vBarInfo(5)
            Else
                lRatio = vBarInfo(1) / vBarInfo(8)
            End If
            vBarInfo(5) = CInt(vBarInfo(5) * lRatio)
            vBarInfo(8) = CInt(vBarInfo(8) * lRatio)
        End If
        vBarInfo(7) = MakeLong(CInt(vBarInfo(5)), CInt(vBarInfo(8)))
        ' save the left & top offsets for the image, this way we don't have
        ' to remeasure when the menu is being displayed.
        vBarInfo(5) = MakeLong((vBarInfo(4) - vBarInfo(5)) \ 2, (vBarInfo(1) - vBarInfo(8)) \ 2)
    Else
        ' if user want's gradient background for text sidebar then
        If InStr(sBarInfo, "|GRADIENT") > 0 And sbarType = 4 Then vBarInfo(9) = vBarInfo(9) Or 32
        ' text sidebar, let's get the forecolor of the text & black is default
        If InStr(sBarInfo, "|FCOLOR:") Then
            vBarInfo(7) = VAL(Mid$(sBarInfo, InStr(sBarInfo, "|FCOLOR:") + 8))
            If vBarInfo(7) < 0 Then vBarInfo(7) = 0
        Else
            vBarInfo(7) = 0
        End If
        vBarInfo(5) = MakeLong(CInt(vBarInfo(5)), CInt(vBarInfo(8)))
    End If
End If
vBarInfo(9) = sbarType Or vBarInfo(9)
vBarInfo(0) = vBarInfo(0) + vBarInfo(4)
'Debug.Print "font?"; (vBarInfo(9) And 4) = 4; vBarInfo(10)
sBarInfo = sText
Exit Sub

DrawPicture:
' this routine is used when....
' 1. When we need the background color for a mask
' 2. Image passed is a control to get height/width values