丹东信息港
时尚
当前位置:首页 > 时尚

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

发布时间:2019-12-05 08:03:28 编辑:笔名

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

调试、运行。 查看本文来源

孩子晚上发烧白天不烧怎么回事
宝宝脸部发黄怎么回事
幼儿发烧怎么办
工作常备腹泻用药有什么
友情链接