如何用vb6建立带光栅的菜单

Public Property Get Caption() As String ’标题栏文字
Caption = m_sCaption
End Property

Public Property Let DrawingObject(ByRef picThis As PictureBox)‘指定目标图片
Set m_picThis = picThis
End Property

Public Property Get StartColor() As OLE_COLOR ‘
StartColor = m_oStartColor
End Property

Public Property Let StartColor(ByVal oColor As OLE_COLOR) ‘指定前段颜色
Dim lColor As Long
If (m_oStartColor $#@60;$#@62; oColor) Then
m_oStartColor = oColor
OleTranslateColor oColor, 0, lColor
m_bRGBStart(1) = lColor And &HFF&
m_bRGBStart(2) = ((lColor And &HFF00&) \ &H100)
m_bRGBStart(3) = ((lColor And &HFF0000) \ &H10000)
If Not (m_picThis Is Nothing) Then
Draw
End If
End If
End Property

Public Property Get EndColor() As OLE_COLOR
EndColor = m_oEndColor
End Property

Public Property Let EndColor(ByVal oColor As OLE_COLOR) ‘指定后段颜色
Dim lColor As Long
If (m_oEndColor $#@60;$#@62; oColor) Then
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 $#@60;$#@62; 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 ‘模块定义结束
（第二步）运行调试；
　　按下f5键，点击“开始”按钮，这时弹出如图片1所示的菜单，与windows的那个相比，它的侧面带双色的渐变的背景，而且它多了一个标题栏“超级菜单--设计者：zouhero”，你可以到处拖动它，怎么样是不是非常厉害,当鼠标移动到form1时，弹出的菜单消失。
　　剩下的就要看你的了，上述代码已经包括程序的核心，你可以适当的加以修改（在界面或者文字上），至于如何设置二级菜单，方法与此类似，你尽可以自己试一下，本文不再赘述。
　　对于国内的程序员来说，涉及windows高级编程的相关资料和示例代码非常少，这在一定程度上限制了程序员的熟练开发高级应用程序能力，本文中的示例不仅仅涉及了界面制作，演示了高级的系统色彩描述技巧，而且暴露了一些看似复杂的应用程序的实质，希望诸位编程高手能够有所借鉴和斧正，以上代码同样适合vb5开发平台。如有问题或者希望相互交流,请与我联系zouworld@sina.com.cn,个人主页 http://zouga.yeah.net，欢迎留言.

文章整理：西部数码--专业提供域名注册、虚拟主机服务
http://www.west263.com
以上信息与文章正文是不可分割的一部分,如果您要转载本文章,请保留以上信息，谢谢!