用VB6創(chuàng)建帶光柵的超級開始菜單
發(fā)表時間：2023-08-21 來源：明輝站整理相關(guān)軟件相關(guān)文章人氣：
[摘要]（一）編程原理； 由于windows自身并未提供這項接口函數(shù)，因此我們必須從分析菜單的實質(zhì)入手，我認(rèn)為任何菜單實質(zhì)上是一個沒有標(biāo)題欄的窗體，菜單項目是某些控件（如標(biāo)簽控件），通過監(jiān)測鼠標(biāo)是否移動...
（一）編程原理；
由于windows自身并未提供這項接口函數(shù)，因此我們必須從分析菜單的實質(zhì)入手，我認(rèn)為任何菜單實質(zhì)上是一個沒有標(biāo)題欄的窗體，菜單項目是某些控件（如標(biāo)簽控件），通過監(jiān)測鼠標(biāo)是否移動到控件上而相應(yīng)的改變控件的背景色和填充色，從而達(dá)到相應(yīng)的目的，當(dāng)然另外一項關(guān)鍵是如何制造出那一個倒立著的寫著“windows98”字樣的標(biāo)題，這需要我們調(diào)用復(fù)雜的系統(tǒng)函數(shù)來實現(xiàn)。
�。ǘ┚幊虒嵺`；
�。�1）運行vb6，建立一個標(biāo)準(zhǔn)exe工程，添加命名為form1的窗體，放上一個command控件“command1”，caption=“開始”，調(diào)整到適當(dāng)?shù)奈恢?雙擊窗體，寫入以下代碼：
Private Sub Command1_Click()
frmTest.Show ‘當(dāng)開始按鈕被點擊時激活超級菜單
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 ‘當(dāng)鼠標(biāo)離開菜單時卸載菜單
End Sub
Private Sub Form_Unload(Cancel As Integer)
End ‘結(jié)束程序
End Sub
�。�2） 添加命名為frmtest的窗體，添加一個picturebox控件，命名為piclogo，采用默認(rèn)值就行了，添加控件數(shù)組label1（1－－6）（讀者可以根據(jù)自己的需要添加）,caption=“菜單項目”，添加一個image控件，將它的圖片設(shè)計為自己喜歡的圖片，移動窗體和圖片到適當(dāng)位置，雙擊窗體，寫入以下代碼：
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 ‘窗體標(biāo)題
cL.DrawingObject = picLogo ‘指定piclogo為載體
cL.Caption = ″ 歡迎使用國產(chǎn)軟件! －－zouhero 2000 ″‘文本
cL.StartColor = vbBlue ‘前段顏色－藍(lán)色
cL.EndColor = vbRed ‘后段顏色－紅色
End 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
’在這里添加你的相應(yīng)代碼
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 ‘當(dāng)鼠標(biāo)移動標(biāo)簽控件時，前景色變成白色，背景色變成藍(lán)色
Label1(Index).BackColor = vbBlue
Label1(Index).ForeColor = ＆HFFFFFF
For i = 0 To Label1.Count － 1 ‘其他標(biāo)簽顏色恢復(fù)原狀
If i = Index Then GoTo aa
Label1(i).BackColor = vbButtonFace
Label1(i).ForeColor = ＆H0
aa:
Next ‘恢復(fù)除選定標(biāo)簽外的所有標(biāo)簽的前景色和背景色
End Sub ‘代碼結(jié)束
�。�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聲明結(jié)束
’以下代碼建立建立類模塊的出入口函數(shù)
Public Property Let Caption(ByVal sCaption As String) ’
m_sCaption = sCaption
End Property
Public Property Get Caption() As String ’標(biāo)題欄文字
Caption = m_sCaption
End Property
Public Property Let DrawingObject(ByRef picThis As PictureBox)‘指定目標(biāo)圖片
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 <> 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 <> 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 <> 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 ‘模塊定義結(jié)束
調(diào)試、運行。
