至顶网›软件频道 ›基础软件›用VB6建立带光栅的超级开始菜单

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

扫一扫
分享文章到微信
扫一扫
关注官方公众号
至顶头条

由于windows自身并未提供这项接口函数，因此我们必须从分析菜单的实质入手

作者：佚名来源：vb新世纪 2007年10月14日

关键字：

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

　　调试、运行。

查看本文来源

VIP专区

VIP用户

普通用户

邮件订阅

如果您非常迫切的想了解IT领域最新产品与技术信息，那么订阅至顶网技术邮件将是您的最佳途径之一。

重磅专题

往期文章

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

业界热点: