用VB6建立带光栅的超级开始菜单
m_oEndColor = oColor
OleTranslateColor oColor, 0, lColor
m_bRGBEnd(1) = lColor And ＆HFF＆
m_bRGBEnd(2) = ((lColor And ＆HFF00＆) \ ＆H100)
m_bRGBEnd(3) = ((lColor And ＆HFF0000) \ ＆H10000)
If Not (m_picThis Is Nothing) Then
Draw
End If
End If
End Property
Public Sub Draw() ‘画背景颜色
Dim lHeight As Long, lWidth As Long
Dim lYStep As Long
Dim lY As Long
Dim bRGB(1 To 3) As Integer
Dim tLF As LOGFONT
Dim hFnt As Long
Dim hFntOld As Long
Dim lR As Long
Dim rct As RECT
Dim hBr As Long
Dim hDC As Long
Dim dR(1 To 3) As Double
On Error GoTo DrawError
hDC = m_picThis.hDC
lHeight = m_picThis.Height \ Screen.TwipsPerPixelY
rct.Right = m_picThis.Width \ Screen.TwipsPerPixelY
lYStep = lHeight \ 255
If (lYStep = 0) Then
lYStep = 1
End If
rct.Bottom = lHeight
bRGB(1) = m_bRGBStart(1)
bRGB(2) = m_bRGBStart(2)
bRGB(3) = m_bRGBStart(3)
dR(1) = m_bRGBEnd(1) － m_bRGBStart(1)
dR(2) = m_bRGBEnd(2) － m_bRGBStart(2)
dR(3) = m_bRGBEnd(3) － m_bRGBStart(3)
For lY = lHeight To 0 Step －lYStep
rct.tOp = rct.Bottom － lYStep
hBr = CreateSolidBrush((bRGB(3) ＊ ＆H10000 ＋ bRGB(2) ＊ ＆H100＆ ＋ bRGB(1)))
FillRect hDC, rct, hBr
DeleteObject hBr
rct.Bottom = rct.tOp
bRGB(1) = m_bRGBStart(1) ＋ dR(1) ＊ (lHeight － lY) / lHeight
bRGB(2) = m_bRGBStart(2) ＋ dR(2) ＊ (lHeight － lY) / lHeight
bRGB(3) = m_bRGBStart(3) ＋ dR(3) ＊ (lHeight － lY) / lHeight
Next lY
pOLEFontToLogFont m_picThis.Font, hDC, tLF
tLF.lfEscapement = 900
hFnt = CreateFontIndirect(tLF)
If (hFnt <> 0) Then
hFntOld = SelectObject(hDC, hFnt)
lR = TextOut(hDC, 0, lHeight － 16, m_sCaption, Len(m_sCaption))
SelectObject hDC, hFntOld
DeleteObject hFnt
End If
m_picThis.Refresh
Exit Sub
DrawError:
Debug.Print ″Problem: ″ ＆ Err.Description
End Sub
Private Sub pOLEFontToLogFont(fntThis As StdFont, hDC As Long, tLF As LOGFONT) ‘文字字体
Dim sFont As String
Dim iChar As Integer
With tLF
sFont = fntThis.Name
For iChar = 1 To Len(sFont)
.lfFaceName(iChar － 1) =CByte(Asc(Mid＄(sFont, iChar, 1)))
Next iChar
.lfHeight = －MulDiv((fntThis.Size), (GetDeviceCaps(hDC, LOGPIXELSY)), 72)
.lfItalic = fntThis.Italic
If (fntThis.Bold) Then
.lfWeight = FW_BOLD
Else
.lfWeight = FW_NORMAL
End If
.lfUnderline = fntThis.Underline
.lfStrikeOut = fntThis.Strikethrough
End With
End Sub
Private Sub Class_Initialize()
StartColor = ＆H0
EndColor = vbButtonFace
End Sub ‘模块定义结束
调试、运行。
OleTranslateColor oColor, 0, lColor
m_bRGBEnd(1) = lColor And ＆HFF＆
m_bRGBEnd(2) = ((lColor And ＆HFF00＆) \ ＆H100)
m_bRGBEnd(3) = ((lColor And ＆HFF0000) \ ＆H10000)
If Not (m_picThis Is Nothing) Then
Draw
End If
End If
End Property
Public Sub Draw() ‘画背景颜色
Dim lHeight As Long, lWidth As Long
Dim lYStep As Long
Dim lY As Long
Dim bRGB(1 To 3) As Integer
Dim tLF As LOGFONT
Dim hFnt As Long
Dim hFntOld As Long
Dim lR As Long
Dim rct As RECT
Dim hBr As Long
Dim hDC As Long
Dim dR(1 To 3) As Double
On Error GoTo DrawError
hDC = m_picThis.hDC
lHeight = m_picThis.Height \ Screen.TwipsPerPixelY
rct.Right = m_picThis.Width \ Screen.TwipsPerPixelY
lYStep = lHeight \ 255
If (lYStep = 0) Then
lYStep = 1
End If
rct.Bottom = lHeight
bRGB(1) = m_bRGBStart(1)
bRGB(2) = m_bRGBStart(2)
bRGB(3) = m_bRGBStart(3)
dR(1) = m_bRGBEnd(1) － m_bRGBStart(1)
dR(2) = m_bRGBEnd(2) － m_bRGBStart(2)
dR(3) = m_bRGBEnd(3) － m_bRGBStart(3)
For lY = lHeight To 0 Step －lYStep
rct.tOp = rct.Bottom － lYStep
hBr = CreateSolidBrush((bRGB(3) ＊ ＆H10000 ＋ bRGB(2) ＊ ＆H100＆ ＋ bRGB(1)))
FillRect hDC, rct, hBr
DeleteObject hBr
rct.Bottom = rct.tOp
bRGB(1) = m_bRGBStart(1) ＋ dR(1) ＊ (lHeight － lY) / lHeight
bRGB(2) = m_bRGBStart(2) ＋ dR(2) ＊ (lHeight － lY) / lHeight
bRGB(3) = m_bRGBStart(3) ＋ dR(3) ＊ (lHeight － lY) / lHeight
Next lY
pOLEFontToLogFont m_picThis.Font, hDC, tLF
tLF.lfEscapement = 900
hFnt = CreateFontIndirect(tLF)
If (hFnt <> 0) Then
hFntOld = SelectObject(hDC, hFnt)
lR = TextOut(hDC, 0, lHeight － 16, m_sCaption, Len(m_sCaption))
SelectObject hDC, hFntOld
DeleteObject hFnt
End If
m_picThis.Refresh
Exit Sub
DrawError:
Debug.Print ″Problem: ″ ＆ Err.Description
End Sub
Private Sub pOLEFontToLogFont(fntThis As StdFont, hDC As Long, tLF As LOGFONT) ‘文字字体
Dim sFont As String
Dim iChar As Integer
With tLF
sFont = fntThis.Name
For iChar = 1 To Len(sFont)
.lfFaceName(iChar － 1) =CByte(Asc(Mid＄(sFont, iChar, 1)))
Next iChar
.lfHeight = －MulDiv((fntThis.Size), (GetDeviceCaps(hDC, LOGPIXELSY)), 72)
.lfItalic = fntThis.Italic
If (fntThis.Bold) Then
.lfWeight = FW_BOLD
Else
.lfWeight = FW_NORMAL
End If
.lfUnderline = fntThis.Underline
.lfStrikeOut = fntThis.Strikethrough
End With
End Sub
Private Sub Class_Initialize()
StartColor = ＆H0
EndColor = vbButtonFace
End Sub ‘模块定义结束
调试、运行。