|
用VB6实现的3D文字按钮
源代码如下：
1、新建EXE工程。
2、添加模块，键入下面代码
' -------- API 函数声明 -----------------
Option Explicit
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
Destination As Any,_
Source As Any,_
ByVal Length As Long)
Public Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" ( _
ByVal hwnd As Long,_
ByVal lpString As String,_
ByVal cch As Long) As Long
Public Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" ( _
lpLogFont As logFont) As Long
Public Const LF_FACESIZE As Long = 32
Public 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(1 To LF_FACESIZE) As Byte
End Type
Public Declare Function BitBlt Lib "gdi32.dll" ( _
ByVal hDestDC As Long,_
ByVal x As Long,_
ByVal y As Long,_
ByVal nWidth As Long,_
ByVal nHeight As Long,_
ByVal hSrcDC As Long,_
ByVal xSrc As Long,_
ByVal ySrc As Long,_
ByVal dwRop As Long) As Long
Public Declare Function DeleteDC Lib "gdi32.dll" ( _
ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
ByVal hdc As Long,_
ByVal nHeight As Long) As Long
Public Declare Function SelectObject Lib "gdi32.dll" ( _
ByVal hdc As Long,_
ByVal hObject As Long) As Long
Public Type Size
cx As Long
cy As Long
End Type
Public Declare Function GetTextExtentPoint Lib "gdi32.dll" Alias "GetTextExtentPointA" ( _
ByVal hdc As Long,_
ByVal lpszString As String,_
ByVal cbString As Long,_
lpSize As Size) As Long
Public Declare Function MulDiv Lib "kernel32.dll" ( _
ByVal nNumber As Long,_
ByVal nNumerator As Long,_
ByVal nDenominator As Long) As Long
Public Declare Function SetBkMode Lib "gdi32.dll" ( _
ByVal hdc As Long,_
ByVal nBkMode As Long) As Long
Public Declare Function GetSysColor Lib "user32.dll" ( _
ByVal nIndex As Long) As Long
Public Declare Function SetTextColor Lib "gdi32.dll" ( _
ByVal hdc As Long,_
ByVal crColor As Long) As Long
Public Declare Function TextOut Lib "gdi32.dll" Alias "TextOutA" ( _
ByVal hdc As Long,_
ByVal nCount As Long) As Long
Public Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long,_
ByVal hwnd As Long,_
ByVal msg As Long,_
ByVal wParam As Long,_
ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
ByVal hwnd As Long,_
ByVal nIndex As Long,_
ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" ( _
ByVal hwnd As Long,_
ByVal nIndex As Long) As Long
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type DRAWITEMSTRUCT
CtlType As Long
CtlID As Long
itemID As Long
itemAction As Long
itemState As Long
hwndItem As Long
hdc As Long
rcItem As RECT
itemData As Long
End Type
Public Declare Function DeleteObject Lib "gdi32.dll" ( _
ByVal hObject As Long) As Long
Public Declare Function FillRect Lib "user32.dll" ( _
ByVal hdc As Long,_
lpRect As RECT,_
ByVal hBrush As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32.dll" ( _
ByVal crColor As Long) As Long
Public Declare Function GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" ( _
ByVal hdc As Long,_
lpMetrics As TEXTMETRIC) As Long
Public Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Public Const WM_DRAWITEM As Long = &H2B
Public Const GWL_WNDPROC As Long = -4
Public Const ODS_SELECTED As Long = &H1
Public Const COLOR_3DDKSHADOW As Long = 21
Public Const COLOR_BTNFACE As Long = 15
Public Const COLOR_BTNHIGHLIGHT As Long = 20
Public Const COLOR_BTNSHADOW As Long = 16
Public Const COLOR_3DLIGHT As Long = 22
Public Const COLOR_3DHIGHLIGHT As Long = COLOR_BTNHIGHLIGHT
Public Const COLOR_3DFACE As Long = COLOR_BTNFACE
Public Const COLOR_3DHILIGHT As Long = COLOR_BTNHIGHLIGHT
Public Const COLOR_3DSHADOW As Long = COLOR_BTNSHADOW
Public Const ODT_BUTTON As Long = 4
Public Const TRANSPARENT As Long = 1
Public Const ODS_DISABLED As Long = &H4
3、再添加一个模块，键入下面代码：
'------------------ 应用SubClass处理 -------------------
' 2003-12-17
' 作者:任兀(DSclub)
'
'如果有问题
'请E-Mail:dsclub@hotmail.com
'
'--------------------------------------------------------
'－－－－－－－－－－－ 说明 －－－－－－－－－－－－－－－－－
'对于想要设置成文字按钮的Command，修改其Style属性为1
'将本模块考入你的程序，然后在你的代码中写入Hook和Unhook即可
'
'----------------------------------------------------------------
Option Explicit
Global lpPrevWndProc As Long
Global gHW As Long
Public Sub Hook()
lpPrevWndProc = SetWindowLong(gHW,GWL_WNDPROC,AddressOf WindowProc)
End Sub
Public Sub Unhook()
Dim temp As Long
temp = SetWindowLong(gHW,lpPrevWndProc)
End Sub
Function WindowProc(ByVal hw As Long,ByVal uMsg As Long,ByVal wParam As Long,ByVal lParam As Long) As Long
Dim DI As DRAWITEMSTRUCT
'捕获 WM_DRAWITEM 消息，并处理
If uMsg = WM_DRAWITEM Then
CopyMemory DI,ByVal lParam,Len(DI)
'找到是Owner-drawn的按钮
If DI.itemAction Or ODT_BUTTON = ODT_BUTTON Then
DrawButton DI.hwndItem,DI.hdc,DI.rcItem,DI.itemState
'-------- 取消系统默认的消息处理 --------------
WindowProc = 1
Exit Function
End If
End If
WindowProc = CallWindowProc(lpPrevWndProc,hw,uMsg,wParam,lParam)
End Function
Public Sub DrawButton(ByVal ButtonHW As Long,ByVal DIhDC As Long,RCT As RECT,ByVal State As Long)
Dim ButtonText As String * 255 '必须设置Buffer
Dim pFont As Long
Dim logFont As logFont
Dim pOldFont As Long
Dim SZ As Size
Dim FString As String
Dim ButtonTextBitLength As Integer
Dim s As Integer
Dim textColor As Long
Dim OldBKMode As Long
Dim cx As Integer
Dim cy As Integer
Dim MemDC As Long
Dim MemBitmap As Long
Dim OldMB As Long
Dim TM As TEXTMETRIC
'使用双缓冲，防止闪烁
MemDC = CreateCompatibleDC(DIhDC)
MemBitmap = CreateCompatibleBitmap(DIhDC,RCT.Right - RCT.Left,RCT.Bottom - RCT.Top)
OldMB = SelectObject(MemDC,MemBitmap)
'得到按钮的初始Caption，并按位计算长度
GetWindowText ButtonHW,ButtonText,255
ButtonTextBitLength = InStrB(1,StrConv(ButtonText,vbFromUnicode),vbNullChar) - 1
'构造逻辑字体
With logFont
.lfHeight = 60
.lfWidth = 0
.lfWeight = 1000
.lfEscapement = 0
.lfOrientation = 0
End With
pFont = CreateFontIndirect(logFont)
pOldFont = SelectObject(MemDC,pFont)
GetTextExtentPoint MemDC,ButtonTextBitLength + 2,SZ '加上一个2,以防有中文出错误
'调整字体大小
If (RCT.Right - RCT.Left) * SZ.cy > (RCT.Bottom - RCT.Top) * SZ.cx Then
logFont.lfHeight = MulDiv(logFont.lfHeight,(RCT.Bottom - RCT.Top),SZ.cy)
Else
logFont.lfHeight = MulDiv(logFont.lfHeight,(RCT.Right - RCT.Left),SZ.cx)
End If
'恢复DC，并使用新的调整好的字体
pFont = CreateFontIndirect(logFont)
DeleteObject (SelectObject(MemDC,pOldFont))
pOldFont = SelectObject(MemDC,ButtonTextBitLength,SZ
cx = RCT.Left + (RCT.Right - RCT.Left - SZ.cx) / 2
cy = RCT.Top + (RCT.Bottom - RCT.Top - SZ.cy) / 2
cx = cx + 2
cy = cy + 2
'处理鼠标按下和抬起的不同消息
If (State And ODS_SELECTED) = ODS_SELECTED Then
s = -1
Else
s = 1
End If
OldBKMode = SetBkMode(MemDC,TRANSPARENT)
'先把BG涂上颜色COLOR_3DFACE
FillRect MemDC,RCT,CreateSolidBrush(GetSysColor(COLOR_3DFACE))
'开始画3D字体边缘
textColor = SetTextColor(MemDC,GetSysColor(COLOR_3DDKSHADOW))
TextOut MemDC,cx - s * 2,cy + s * 2,ButtonTextBitLength
TextOut MemDC,cx + s * 2,cy - s * 2,ButtonTextBitLength
SetTextColor MemDC,GetSysColor(COLOR_3DHILIGHT)
TextOut MemDC,cx + s,cy + s,GetSysColor(COLOR_3DSHADOW)
TextOut MemDC,cx - s,cy - s,GetSysColor(COLOR_3DLIGHT)
TextOut MemDC,cx,cy,ButtonTextBitLength
'处理按钮的Enanbled状态
If (State And ODS_DISABLED) = ODS_DISABLED Then
SetTextColor MemDC,ButtonTextBitLength
Else
SetTextColor MemDC,textColor
TextOut MemDC,ButtonTextBitLength
End If
'一次性传输到Button的可视DC
BitBlt DIhDC,RCT.Bottom - RCT.Top,MemDC,vbSrcCopy
'恢复 DC SetBkMode MemDC,OldBKMode DeleteObject (SelectObject(MemDC,pOldFont)) SetTextColor MemDC,textColor pFont = 0 pOldFont = 0 DeleteObject (SelectObject(MemDC,OldMB)) DeleteObject MemBitmap DeleteDC MemDC End Sub4、在Form1窗体上，放入CommmadnButton，并将想变成3D按钮的CommandButton的Style属性设置成1-Graphical。再Form1的代码中输入下面代码启动。Private Sub Form_Load()gHW = Me.hwndHookEnd SubPrivate Sub Form_Unload(Cancel As Integer)UnhookEnd Sub5、运行来看看。 （编辑：李大同）
【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!
|
