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

如何用vb6建立带光栅的菜单
2000-08-12 00:00作者：新天出处：yesky责任编辑：p>　　编程爱好者一定对windows98中非常惹眼的“开始”菜单羡慕不已，但是微软公司

似乎对它的这个杰作存心垄断,它没有提供任何可供借用的方法来实现,笔者一直对此心存芥蒂,于是决定自己动手制作。

（一）编程原理；
　　由于windows自身并未提供这项接口函数，因此我们必须从分析菜单的实质入手，我认为任何菜单实质上是一个没有标题栏的窗体，菜单项

目是某些控件（如标签控件），通过监测鼠标是否移动到控件上而相应的改变控件的背景色和填充色，从而达到相应的目的，当然另外一项关

键是如何制造出那一个倒立着的写着“windows98”字样的标题，这需要我们调用复杂的系统函数来实现。
（二）编程实践；
（第一步）建立工程；
　　（1）运行vb6，建立一个标准exe工程，添加命名为form1的窗体，放上一个command控件“command1”，caption=“开始”，调整到适当的

位置，双击窗体，写入以下代码：
Private Sub Command1_Click()
frmTest.Show ‘当开始按钮被点击时激活超级菜单
End Sub

Private Sub Form_Load()
Me.left = (Screen.Width - Me.Width) / 2
Me.tOp = (Screen.Height - Me.Height) / 2 ‘窗体位置居中
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If frmTest.Visible = True Then
Unload frmTest
End If ‘当鼠标离开菜单时卸载菜单
End Sub

Private Sub Form_Unload(Cancel As Integer)
End ‘结束程序
End Sub
　　（2） 添加命名为frmtest的窗体，添加一个picturebox控件，命名为piclogo，采用默认值就行了，添加控件数组label1（1--6）（读者

可以根据自己的需要添加）,caption=“菜单项目”，添加一个image控件，将它的图片设计为自己喜欢的图片，移动窗体和图片到适当位置，

双击窗体，写入以下代码：
Option Explicit

Dim cL As New cLogo ‘引用类模块

Private Sub Form_Load()
Me.left = Form1.left
Me.tOp = Form1.tOp - Form1.Height ‘指定窗体位置
Me.Caption = App.Title ‘窗体标题
cL.DrawingObject = picLogo ‘指定piclogo为载体
cL.Caption = " 欢迎使用国产软件! --zouhero 2000 "‘文本
cL.StartColor = vbBlue ‘前段颜色-蓝色
cL.EndColor = vbRed ‘后段颜色-红色
E Sub

Private Sub Form_Resize()
On Error Resume Next
picLogo.Height = Me.ScaleHeight
cL.Draw
End Sub

Private Sub Label1_Click(Index As Integer)
MsgBox "你选择了菜单" & Index, vbExclamation
在这里添加你的相应代码
End Sub

Private Sub Label1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer ‘当鼠标移动标签控件时，前景色变成白色
，背景色变成蓝色
Label1(Index).BackColor = vbBlue
Label1(Index).ForeColor = &HFFFFFF
For i = 0 To Label1.Count - 1 ‘其他标签颜色恢复原状
If i = Index Then GoTo aa
Label1(i).BackColor = vbButtonFace
Label1(i).ForeColor = &H0
aa:
Next ‘恢复除选定标签外的所有标签的前景色和背景色
End Sub ‘代码结束
（3）选择“工程”菜单-“添加类模块”，命名为clogo，写入以下代码：
Option Explicit 以下是令人眼花缭乱的win api引用

Private Type RECT
left As Long
tOp As Long
Right As Long
Bottom As Long
End Type

Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal

lpString As String, ByVal nCount As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90

Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long)

As Long

Private Const LF_FACESIZE = 32

Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1

Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As

Long) As Long

Private Const CLR_INVALID = -1
Private m_picThis As PictureBox
Private m_sCaption As String
Private m_bRGBStart(1 To 3) As Integer
Private m_oStartColor As OLE_COLOR
Private m_bRGBEnd(1 To 3) As Integer
Private m_oEndColor As OLE_COLOR ’api声明结束
’以下代码建立建立类模块的出入口函数
Public Property Let Caption(ByVal sCaption As String) ’
m_sCaption = sCaption
End Property

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开发平台。如有问题或者希望相互交流,请与我联系[e-mail],个人主页

http://zouga.yeah.net，欢迎留言.