164.txt

介绍VB里的各种控件的使用方法,窗口控制,图像编程以及OCX等内容,还提供了一个API集供参考.

用VB6建立带光栅的超级开始菜单

　　


　　（一）编程原理； 


　　由于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 ‘后段颜色－红色 


　　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 


　　’在这里添加你的相应代码 


　　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 <> 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 ‘模块定义结束 


　　调试、运行。