' 2003-12-17
' ??:??(DSclub)
'
'?????
'?E-Mail:dsclub@hotmail.com
'
'--------------------------------------------------------
'??????????? ?? ?????????????????
'????????????Command????Style???1
'?????????????????????Hook?Unhook??
' -------- 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 nWidth 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 x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
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
'------------------ ??SubClass?? -------------------
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, GWL_WNDPROC, 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, ButtonText, 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, pFont)
GetTextExtentPoint MemDC, ButtonText, 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, ButtonText, ButtonTextBitLength
TextOut MemDC, cx + s * 2, cy - s * 2, ButtonText, ButtonTextBitLength
TextOut MemDC, cx + s * 2, cy + s * 2, ButtonText, ButtonTextBitLength
SetTextColor MemDC, GetSysColor(COLOR_3DHILIGHT)
TextOut MemDC, cx + s, cy - s * 2, ButtonText, ButtonTextBitLength
TextOut MemDC, cx - s * 2, cy + s, ButtonText, ButtonTextBitLength
TextOut MemDC, cx - s * 2, cy - s * 2, ButtonText, ButtonTextBitLength
SetTextColor MemDC, GetSysColor(COLOR_3DSHADOW)
TextOut MemDC, cx - s, cy + s, ButtonText, ButtonTextBitLength
TextOut MemDC, cx + s, cy - s, ButtonText, ButtonTextBitLength
TextOut MemDC, cx + s, cy + s, ButtonText, ButtonTextBitLength
SetTextColor MemDC, GetSysColor(COLOR_3DLIGHT)
TextOut MemDC, cx, cy - s, ButtonText, ButtonTextBitLength
TextOut MemDC, cx - s, cy, ButtonText, ButtonTextBitLength
TextOut MemDC, cx - s, cy - s, ButtonText, ButtonTextBitLength
'?????Enanbled??
If (State And ODS_DISABLED) = ODS_DISABLED Then
SetTextColor MemDC, GetSysColor(COLOR_3DSHADOW)
TextOut MemDC, cx, cy, ButtonText, ButtonTextBitLength
Else
SetTextColor MemDC, textColor
TextOut MemDC, cx, cy, ButtonText, ButtonTextBitLength
End If
'??????Button???DC
BitBlt DIhDC, 0, 0, RCT.Right - RCT.Left, RCT.Bottom - RCT.Top, MemDC, 0, 0, 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 Sub
Last edited by xiaoyao; Aug 14th, 2024 at 08:43 AM.
On the Form1 form, put CommmadnButton,
And set the Style property of the CommandButton that you want to turn into a 3D button to 1-graphic?
Enter the following code to start in the code of' Form1'
Private Sub Form_Load()
gHW = Me.hwnd
Hook
End Sub
Private Sub Form_Unload(Cancel As Integer)
Unhook
End Sub
On the Form1 form, put CommmadnButton,
And set the Style property of the CommandButton that you want to turn into a 3D button to 1-graphic?
Enter the following code to start in the code of' Form1'
Private Sub Form_Load()
gHW = Me.hwnd
Hook
End Sub
Private Sub Form_Unload(Cancel As Integer)
Unhook
End Sub
Looks Great., but would like to set the forecolor on each button. I can change it in the module but it effects all the buttons with same color.
What he's trying to say is that you can change the text color of each button based on its hWnd using the "SetTextColor" function like in the code posted above.
What he's trying to say is that you can change the text color of each button based on its hWnd using the "SetTextColor" function like in the code posted above.
Private Sub Form_Load()
gHW = Me.hwnd
SetTextColor Command2.hwnd, vbRed
Hook
End Sub
above code did nothing. I have one button (command2) on the form
I meant change the code above to use different colors in the calls to "SetTextColor" in the "DrawButton" function based on the "ButtonHW" parameter if you want different colors for different buttons.
I meant change the code above to use different colors in the calls to "SetTextColor" in the "DrawButton" function based on the "ButtonHW" parameter if you want different colors for different buttons.
I still have not been able to change individual forecolor. I can change color but it effects all the buttons. Any one else been able to make the colors change ?
Last edited by KFrosty; Aug 12th, 2024 at 10:25 AM.
I still have not been able to change individual forecolor. I can change color but it effects all the buttons. Any one else been able to make the colors change ?
how to set button text color,like this:
form1:
Code:
Private Sub Form_Load()
ButtonColor.Add vbRed, Command1.hwnd & ""
ButtonColor.Add vbBlue, Command2.hwnd & ""
Debug.Print Command1.hwnd
Debug.Print Command2.hwnd
gHW = Me.hwnd
Hook
End Sub
Code:
Public ButtonColor As New Collection
Public Sub DrawButton(ByVal ButtonHW As Long, ByVal DIhDC As Long, RCT As RECT, ByVal State As Long)
******
If (State And ODS_DISABLED) = ODS_DISABLED Then
SetTextColor MemDC, GetSysColor(COLOR_3DSHADOW)
TextOut MemDC, cx, cy, ButtonText, ButtonTextBitLength
Else
'SetTextColor MemDC, textColor
'abcd change code here:
On Error Resume Next
Dim myTxtColor As Long
myTxtColor = ButtonColor(ButtonHW & "")
If myTxtColor = 0 Then myTxtColor = textColor
SetTextColor MemDC, myTxtColor
TextOut MemDC, cx, cy, ButtonText, ButtonTextBitLength
End If
BitBlt DIhDC, 0, 0, RCT.Right - RCT.Left, RCT.Bottom - RCT.Top, MemDC, 0, 0, vbSrcCopy
Last edited by xiaoyao; Aug 14th, 2024 at 08:43 AM.
Reason: please move to vb6 code bank
vb6 3d button
Reply With Quote
Originally Posted by xiaoyao
