?? 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
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -