-
vb.net教程之Visual Basic 6子类化的实现
Visual Basic 6子类化的实现（相关vb.net教程)
在Visual Basic 6子类化的实现中我们将通过一段代码的实例来介绍这一技术在VB6中的应用。现在很多开发社区中经常谈到的一个话题就是界面开发如何Skin，这种技术有很多解决方式，如使用可以贴图的控件或使用第三方开发的换肤ActiveX控件。其实Skin技术需要处理的是WM_DRAWITEM、WM_MEASUREITEM、WM_NCPAINT消息，这些消息的主要用途就是可以重画控件和窗口的非客户区。想要对这些VB6无法处理的消息进行编程就必须用到子类化，这些消息都会被发送到能够自绘的控件的窗口上，因此下面的例子就是利用窗口子类化来重画Button控件。
①创建工程
启动Visual Basic 6同时创建一个标准EXE工程。
②窗口布局
在FORM1上放置3个Button控件，并将前两个Button的Style属性设置为1-Graphical，因为只有Style属性设置为Graphical的Button才可以Owner-drawn。
③在窗体中录入代码
现在我们比较一下传统式样Button和新新式样Button的区别吧，这个例子虽然代码很多，而且用到了一些GDI函数，但是子类化技术实际上只需要Init、Terminate、SubWndProc三个函数，因为我们处理了较复杂的重画操作，所以样例看上去很长。
需要指出的是不正确的子类化是非常危险的，将导致一个General Protection Fault（GPF）错误，致使VB应用立即崩溃。
下面的例子将演示如何将About加入窗口的系统菜单。
①创建工程
启动Visual Basic 6同时创建一个标准EXE工程。
②在窗体中录入代码
在Visual Basic 6子类化的实现中我们将通过一段代码的实例来介绍这一技术在VB6中的应用。现在很多开发社区中经常谈到的一个话题就是界面开发如何Skin，这种技术有很多解决方式，如使用可以贴图的控件或使用第三方开发的换肤ActiveX控件。其实Skin技术需要处理的是WM_DRAWITEM、WM_MEASUREITEM、WM_NCPAINT消息，这些消息的主要用途就是可以重画控件和窗口的非客户区。想要对这些VB6无法处理的消息进行编程就必须用到子类化，这些消息都会被发送到能够自绘的控件的窗口上，因此下面的例子就是利用窗口子类化来重画Button控件。
①创建工程
启动Visual Basic 6同时创建一个标准EXE工程。
②窗口布局
在FORM1上放置3个Button控件，并将前两个Button的Style属性设置为1-Graphical，因为只有Style属性设置为Graphical的Button才可以Owner-drawn。
③在窗体中录入代码
Private Sub Command3_Click()
'通过Enabled属性的控制，来显示重画控件在Unenabled状态时的效果
If Command1.Enabled Then
Command1.Enabled = False
Else
Command1.Enabled = True
End If
End Sub
Private Sub Form_Load()
'安装子类化入口
Call Init(Me.hWnd)
End Sub
Private Sub Form_Unload(Cancel As Integer)
'卸载子类化
Call Terminate(Me.hWnd)
End Sub
④加入一个模块并录入代码'通过Enabled属性的控制，来显示重画控件在Unenabled状态时的效果
If Command1.Enabled Then
Command1.Enabled = False
Else
Command1.Enabled = True
End If
End Sub
Private Sub Form_Load()
'安装子类化入口
Call Init(Me.hWnd)
End Sub
Private Sub Form_Unload(Cancel As Integer)
'卸载子类化
Call Terminate(Me.hWnd)
End Sub
Option Explicit
' -- 引用Win32Api –
'得到默认的窗口消息处理过程的地址需要的API
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
'设置一个新的窗口消息处理过程的地址需要的API
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'给指定的窗口消息处理过程传递消息需要的API
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'内存拷贝
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Const GWL_WNDPROC = (-4&)
Dim PrevWndProc&
Private Const WM_DESTROY = &H2
Private Const WM_DRAWITEM = &H2B
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'WM_DRAWITEM需要处理的结构体
Private 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
' Owner draw 常量
Private Const ODT_BUTTON = 4
' Owner draw 动作
Private Const ODA_DRAWENTIRE = &H1
Private Const ODA_SELECT = &H2
Private Const ODA_FOCUS = &H4
' Owner draw 状态
Private Const ODS_SELECTED = &H1
Private Const ODS_GRAYED = &H2
Private Const ODS_DISABLED = &H4
Private Const ODS_CHECKED = &H8
Private Const ODS_FOCUS = &H10
'得到指定窗口的文本
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
'GDI相关API函数，重画Button时使用
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
'色彩常量
Const COLOR_SCROLLBAR = 0
Const COLOR_BACKGROUND = 1
Const COLOR_ACTIVECAPTION = 2
Const COLOR_INACTIVECAPTION = 3
Const COLOR_MENU = 4
Const COLOR_WINDOW = 5
Const COLOR_WINDOWFRAME = 6
Const COLOR_MENUTEXT = 7
Const COLOR_WINDOWTEXT = 8
Const COLOR_CAPTIONTEXT = 9
Const COLOR_ACTIVEBORDER = 10
Const COLOR_INACTIVEBORDER = 11
Const COLOR_APPWORKSPACE = 12
Const COLOR_HIGHLIGHT = 13
Const COLOR_HIGHLIGHTTEXT = 14
Const COLOR_BTNFACE = 15
Const COLOR_BTNSHADOW = 16
Const COLOR_GRAYTEXT = 17
Const COLOR_BTNTEXT = 18
Const COLOR_INACTIVECAPTIONTEXT = 19
Const COLOR_BTNHIGHLIGHT = 20
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
'画笔格式
Const PS_SOLID = 0
Const PS_DASH = 1 ' -------
Const PS_DOT = 2 ' .......
Const PS_DASHDOT = 3 ' _._._._
Const PS_DASHDOTDOT = 4 ' _.._.._
Const PS_NULL = 5
Const PS_INSIDEFRAME = 6
Const PS_USERSTYLE = 7
Const PS_ALTERNATE = 8
Const PS_STYLE_MASK = &HF
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_SINGLELINE = &H20
Private Const DT_CENTER = &H1
Private Const DT_VCENTER = &H4
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Const TRANSPARENT = 1
' – 声明结束 --
Private Sub DrawButton(ByVal hWnd As Long, ByVal hdc As Long, rct As RECT, ByVal nState As Long)
Dim P As POINTAPI
Dim s As String
Dim hbr As Long
Dim hpen As Long
hbr = CreateSolidBrush(GetSysColor(COLOR_BTNFACE)) '获得按钮的背景颜色RGB(231, 231, 231)
SelectObject hdc, hbr '选择使用刷子
FillRect hdc, rct, hbr
DeleteObject hbr
'画文字时背景为透明状
SetBkMode hdc, TRANSPARENT
'得到Button的Caption
s = String$(255, " ")
GetWindowText hWnd, s, 255
s = Trim$(s)
'根据Button的Enabled状态进行重画
If (nState And ODS_DISABLED) = ODS_DISABLED Then
'画外围灰框
hbr = CreateSolidBrush(RGB(132, 130, 132))
SelectObject hdc, hbr
FrameRect hdc, rct, hbr
DeleteObject hbr
'画内侧3D效果->亮色
hpen = CreatePen(PS_SOLID, 1, RGB(255, 255, 255))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Right - 1, rct.Top + 1
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Left + 1, rct.Bottom - 1
DeleteObject hpen
'画内侧3D效果->暗色
hpen = CreatePen(PS_SOLID, 1, RGB(189, 190, 189))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Bottom - 2, P
LineTo hdc, rct.Right - 1, rct.Bottom - 2
MoveToEx hdc, rct.Right - 2, rct.Top + 1, P
LineTo hdc, rct.Right - 2, rct.Bottom - 1
DeleteObject hpen
'画阴影文字
rct.Left = rct.Left + 1
rct.Right = rct.Right + 1
rct.Bottom = rct.Bottom + 1
rct.Top = rct.Top + 1
SetTextColor hdc, GetSysColor(COLOR_BTNHIGHLIGHT)
DrawText hdc, s, LenB(StrConv(s, vbFromUnicode)), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
rct.Left = rct.Left - 1
rct.Right = rct.Right - 1
rct.Bottom = rct.Bottom - 1
rct.Top = rct.Top - 1
SetTextColor hdc, GetSysColor(COLOR_GRAYTEXT)
DrawText hdc, s, LenB(StrConv(s, vbFromUnicode)), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
Exit Sub
End If
'按下Button时重画
If (nState And ODS_SELECTED) = ODS_SELECTED Then
'画内部区域颜色
hbr = CreateSolidBrush(RGB(156, 186, 222))
SelectObject hdc, hbr
FillRect hdc, rct, hbr
DeleteObject hbr
'画外围灰框
hbr = CreateSolidBrush(RGB(99, 125, 165))
SelectObject hdc, hbr
FrameRect hdc, rct, hbr
DeleteObject hbr
'画内侧3D效果->亮色
hpen = CreatePen(PS_SOLID, 1, RGB(123, 158, 206))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Right - 1, rct.Top + 1
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Left + 1, rct.Bottom - 1
DeleteObject hpen
'画内侧3D效果->暗色
hpen = CreatePen(PS_SOLID, 1, RGB(181, 203, 231))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Bottom - 2, P
LineTo hdc, rct.Right - 1, rct.Bottom - 2
MoveToEx hdc, rct.Right - 2, rct.Top + 1, P
LineTo hdc, rct.Right - 2, rct.Bottom - 1
DeleteObject hpen
rct.Left = rct.Left + 1
rct.Right = rct.Right + 1
rct.Bottom = rct.Bottom + 1
rct.Top = rct.Top + 1
SetTextColor hdc, GetSysColor(COLOR_BTNTEXT)
DrawText hdc, s, LenB(StrConv(s, vbFromUnicode)), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
Exit Sub
End If
'Button得到焦点时重画
If (nState And ODS_FOCUS) = ODS_FOCUS Then
'画内部区域颜色
hbr = CreateSolidBrush(RGB(173, 203, 239))
SelectObject hdc, hbr
FillRect hdc, rct, hbr
DeleteObject hbr
'画外围灰框
hbr = CreateSolidBrush(RGB(107, 138, 181))
SelectObject hdc, hbr
FrameRect hdc, rct, hbr
DeleteObject hbr
'画内侧3D效果->亮色
hpen = CreatePen(PS_SOLID, 1, RGB(198, 223, 247))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Right - 1, rct.Top + 1
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Left + 1, rct.Bottom - 1
DeleteObject hpen
'画内侧3D效果->暗色
hpen = CreatePen(PS_SOLID, 1, RGB(132, 174, 222))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Bottom - 2, P
LineTo hdc, rct.Right - 1, rct.Bottom - 2
MoveToEx hdc, rct.Right - 2, rct.Top + 1, P
LineTo hdc, rct.Right - 2, rct.Bottom - 1
DeleteObject hpen
SetTextColor hdc, GetSysColor(COLOR_BTNTEXT)
DrawText hdc, s, LenB(StrConv(s, vbFromUnicode)), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
Else
'画外围灰框
hbr = CreateSolidBrush(RGB(132, 130, 132))
SelectObject hdc, hbr
FrameRect hdc, rct, hbr
DeleteObject hbr
'画内侧3D效果->亮色
hpen = CreatePen(PS_SOLID, 1, RGB(255, 255, 255))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Right - 1, rct.Top + 1
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Left + 1, rct.Bottom - 1
DeleteObject hpen
'画内侧3D效果->暗色
hpen = CreatePen(PS_SOLID, 1, RGB(189, 190, 189))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Bottom - 2, P
LineTo hdc, rct.Right - 1, rct.Bottom - 2
MoveToEx hdc, rct.Right - 2, rct.Top + 1, P
LineTo hdc, rct.Right - 2, rct.Bottom - 1
DeleteObject hpen
'画文字
SetTextColor hdc, GetSysColor(COLOR_BTNTEXT)
DrawText hdc, s, LenB(StrConv(s, vbFromUnicode)), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
End If
End Sub
'新的窗口消息处理过程，将被插入到默认处理过程之前
Private Function SubWndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim di As DRAWITEMSTRUCT
If Msg = WM_DESTROY Then Terminate (hWnd)
'处理自画消息
If Msg = WM_DRAWITEM Then
CopyMemory di, ByVal lParam, Len(di)
'判断是自画Button
If di.CtlType = ODT_BUTTON Then
DrawButton di.hwndItem, di.hdc, di.rcItem, di.itemState
'不返回VB的默认Button绘制过程
SubWndProc = 1
Exit Function
End If
End If
'调用默认的窗口处理过程
SubWndProc = CallWindowProc(PrevWndProc, hWnd, Msg, wParam, lParam)
End Function
'子类化入口
Public Sub Init(hWnd As Long)
PrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SubWndProc)
End Sub
'子类化出口
Public Sub Terminate(hWnd As Long)
Call SetWindowLong(hWnd, GWL_WNDPROC, PrevWndProc)
End Sub
' -- 模块结束 -- '
⑤运行结果' -- 引用Win32Api –
'得到默认的窗口消息处理过程的地址需要的API
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
'设置一个新的窗口消息处理过程的地址需要的API
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'给指定的窗口消息处理过程传递消息需要的API
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'内存拷贝
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Const GWL_WNDPROC = (-4&)
Dim PrevWndProc&
Private Const WM_DESTROY = &H2
Private Const WM_DRAWITEM = &H2B
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'WM_DRAWITEM需要处理的结构体
Private 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
' Owner draw 常量
Private Const ODT_BUTTON = 4
' Owner draw 动作
Private Const ODA_DRAWENTIRE = &H1
Private Const ODA_SELECT = &H2
Private Const ODA_FOCUS = &H4
' Owner draw 状态
Private Const ODS_SELECTED = &H1
Private Const ODS_GRAYED = &H2
Private Const ODS_DISABLED = &H4
Private Const ODS_CHECKED = &H8
Private Const ODS_FOCUS = &H10
'得到指定窗口的文本
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
'GDI相关API函数，重画Button时使用
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
'色彩常量
Const COLOR_SCROLLBAR = 0
Const COLOR_BACKGROUND = 1
Const COLOR_ACTIVECAPTION = 2
Const COLOR_INACTIVECAPTION = 3
Const COLOR_MENU = 4
Const COLOR_WINDOW = 5
Const COLOR_WINDOWFRAME = 6
Const COLOR_MENUTEXT = 7
Const COLOR_WINDOWTEXT = 8
Const COLOR_CAPTIONTEXT = 9
Const COLOR_ACTIVEBORDER = 10
Const COLOR_INACTIVEBORDER = 11
Const COLOR_APPWORKSPACE = 12
Const COLOR_HIGHLIGHT = 13
Const COLOR_HIGHLIGHTTEXT = 14
Const COLOR_BTNFACE = 15
Const COLOR_BTNSHADOW = 16
Const COLOR_GRAYTEXT = 17
Const COLOR_BTNTEXT = 18
Const COLOR_INACTIVECAPTIONTEXT = 19
Const COLOR_BTNHIGHLIGHT = 20
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
'画笔格式
Const PS_SOLID = 0
Const PS_DASH = 1 ' -------
Const PS_DOT = 2 ' .......
Const PS_DASHDOT = 3 ' _._._._
Const PS_DASHDOTDOT = 4 ' _.._.._
Const PS_NULL = 5
Const PS_INSIDEFRAME = 6
Const PS_USERSTYLE = 7
Const PS_ALTERNATE = 8
Const PS_STYLE_MASK = &HF
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_SINGLELINE = &H20
Private Const DT_CENTER = &H1
Private Const DT_VCENTER = &H4
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Const TRANSPARENT = 1
' – 声明结束 --
Private Sub DrawButton(ByVal hWnd As Long, ByVal hdc As Long, rct As RECT, ByVal nState As Long)
Dim P As POINTAPI
Dim s As String
Dim hbr As Long
Dim hpen As Long
hbr = CreateSolidBrush(GetSysColor(COLOR_BTNFACE)) '获得按钮的背景颜色RGB(231, 231, 231)
SelectObject hdc, hbr '选择使用刷子
FillRect hdc, rct, hbr
DeleteObject hbr
'画文字时背景为透明状
SetBkMode hdc, TRANSPARENT
'得到Button的Caption
s = String$(255, " ")
GetWindowText hWnd, s, 255
s = Trim$(s)
'根据Button的Enabled状态进行重画
If (nState And ODS_DISABLED) = ODS_DISABLED Then
'画外围灰框
hbr = CreateSolidBrush(RGB(132, 130, 132))
SelectObject hdc, hbr
FrameRect hdc, rct, hbr
DeleteObject hbr
'画内侧3D效果->亮色
hpen = CreatePen(PS_SOLID, 1, RGB(255, 255, 255))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Right - 1, rct.Top + 1
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Left + 1, rct.Bottom - 1
DeleteObject hpen
'画内侧3D效果->暗色
hpen = CreatePen(PS_SOLID, 1, RGB(189, 190, 189))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Bottom - 2, P
LineTo hdc, rct.Right - 1, rct.Bottom - 2
MoveToEx hdc, rct.Right - 2, rct.Top + 1, P
LineTo hdc, rct.Right - 2, rct.Bottom - 1
DeleteObject hpen
'画阴影文字
rct.Left = rct.Left + 1
rct.Right = rct.Right + 1
rct.Bottom = rct.Bottom + 1
rct.Top = rct.Top + 1
SetTextColor hdc, GetSysColor(COLOR_BTNHIGHLIGHT)
DrawText hdc, s, LenB(StrConv(s, vbFromUnicode)), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
rct.Left = rct.Left - 1
rct.Right = rct.Right - 1
rct.Bottom = rct.Bottom - 1
rct.Top = rct.Top - 1
SetTextColor hdc, GetSysColor(COLOR_GRAYTEXT)
DrawText hdc, s, LenB(StrConv(s, vbFromUnicode)), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
Exit Sub
End If
'按下Button时重画
If (nState And ODS_SELECTED) = ODS_SELECTED Then
'画内部区域颜色
hbr = CreateSolidBrush(RGB(156, 186, 222))
SelectObject hdc, hbr
FillRect hdc, rct, hbr
DeleteObject hbr
'画外围灰框
hbr = CreateSolidBrush(RGB(99, 125, 165))
SelectObject hdc, hbr
FrameRect hdc, rct, hbr
DeleteObject hbr
'画内侧3D效果->亮色
hpen = CreatePen(PS_SOLID, 1, RGB(123, 158, 206))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Right - 1, rct.Top + 1
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Left + 1, rct.Bottom - 1
DeleteObject hpen
'画内侧3D效果->暗色
hpen = CreatePen(PS_SOLID, 1, RGB(181, 203, 231))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Bottom - 2, P
LineTo hdc, rct.Right - 1, rct.Bottom - 2
MoveToEx hdc, rct.Right - 2, rct.Top + 1, P
LineTo hdc, rct.Right - 2, rct.Bottom - 1
DeleteObject hpen
rct.Left = rct.Left + 1
rct.Right = rct.Right + 1
rct.Bottom = rct.Bottom + 1
rct.Top = rct.Top + 1
SetTextColor hdc, GetSysColor(COLOR_BTNTEXT)
DrawText hdc, s, LenB(StrConv(s, vbFromUnicode)), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
Exit Sub
End If
'Button得到焦点时重画
If (nState And ODS_FOCUS) = ODS_FOCUS Then
'画内部区域颜色
hbr = CreateSolidBrush(RGB(173, 203, 239))
SelectObject hdc, hbr
FillRect hdc, rct, hbr
DeleteObject hbr
'画外围灰框
hbr = CreateSolidBrush(RGB(107, 138, 181))
SelectObject hdc, hbr
FrameRect hdc, rct, hbr
DeleteObject hbr
'画内侧3D效果->亮色
hpen = CreatePen(PS_SOLID, 1, RGB(198, 223, 247))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Right - 1, rct.Top + 1
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Left + 1, rct.Bottom - 1
DeleteObject hpen
'画内侧3D效果->暗色
hpen = CreatePen(PS_SOLID, 1, RGB(132, 174, 222))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Bottom - 2, P
LineTo hdc, rct.Right - 1, rct.Bottom - 2
MoveToEx hdc, rct.Right - 2, rct.Top + 1, P
LineTo hdc, rct.Right - 2, rct.Bottom - 1
DeleteObject hpen
SetTextColor hdc, GetSysColor(COLOR_BTNTEXT)
DrawText hdc, s, LenB(StrConv(s, vbFromUnicode)), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
Else
'画外围灰框
hbr = CreateSolidBrush(RGB(132, 130, 132))
SelectObject hdc, hbr
FrameRect hdc, rct, hbr
DeleteObject hbr
'画内侧3D效果->亮色
hpen = CreatePen(PS_SOLID, 1, RGB(255, 255, 255))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Right - 1, rct.Top + 1
MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
LineTo hdc, rct.Left + 1, rct.Bottom - 1
DeleteObject hpen
'画内侧3D效果->暗色
hpen = CreatePen(PS_SOLID, 1, RGB(189, 190, 189))
SelectObject hdc, hpen
MoveToEx hdc, rct.Left + 1, rct.Bottom - 2, P
LineTo hdc, rct.Right - 1, rct.Bottom - 2
MoveToEx hdc, rct.Right - 2, rct.Top + 1, P
LineTo hdc, rct.Right - 2, rct.Bottom - 1
DeleteObject hpen
'画文字
SetTextColor hdc, GetSysColor(COLOR_BTNTEXT)
DrawText hdc, s, LenB(StrConv(s, vbFromUnicode)), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
End If
End Sub
'新的窗口消息处理过程，将被插入到默认处理过程之前
Private Function SubWndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim di As DRAWITEMSTRUCT
If Msg = WM_DESTROY Then Terminate (hWnd)
'处理自画消息
If Msg = WM_DRAWITEM Then
CopyMemory di, ByVal lParam, Len(di)
'判断是自画Button
If di.CtlType = ODT_BUTTON Then
DrawButton di.hwndItem, di.hdc, di.rcItem, di.itemState
'不返回VB的默认Button绘制过程
SubWndProc = 1
Exit Function
End If
End If
'调用默认的窗口处理过程
SubWndProc = CallWindowProc(PrevWndProc, hWnd, Msg, wParam, lParam)
End Function
'子类化入口
Public Sub Init(hWnd As Long)
PrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SubWndProc)
End Sub
'子类化出口
Public Sub Terminate(hWnd As Long)
Call SetWindowLong(hWnd, GWL_WNDPROC, PrevWndProc)
End Sub
' -- 模块结束 -- '
现在我们比较一下传统式样Button和新新式样Button的区别吧，这个例子虽然代码很多，而且用到了一些GDI函数，但是子类化技术实际上只需要Init、Terminate、SubWndProc三个函数，因为我们处理了较复杂的重画操作，所以样例看上去很长。
需要指出的是不正确的子类化是非常危险的，将导致一个General Protection Fault（GPF）错误，致使VB应用立即崩溃。
下面的例子将演示如何将About加入窗口的系统菜单。
①创建工程
启动Visual Basic 6同时创建一个标准EXE工程。
②在窗体中录入代码
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function InsertMenu Lib "user32" Alias "InsertMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400&
Private Const MF_STRING = &H0&
Private Const MF_SEPARATOR = &H800&
Private Sub Form_Load()
InsertMenu GetSystemMenu(Me.hWnd, False), 0, MF_BYPOSITION Or MF_SEPARATOR, 2001, ""
InsertMenu GetSystemMenu(Me.hWnd, False), 0, MF_BYPOSITION Or MF_STRING, 2002, "About Me(&A)"
'安装子类化入口
Call Init(Me.hWnd)
End Sub
Private Sub Form_Unload(Cancel As Integer)
'卸载子类化
Call Terminate(Me.hWnd)
End Sub
③加入一个模块并录入代码Private Declare Function InsertMenu Lib "user32" Alias "InsertMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400&
Private Const MF_STRING = &H0&
Private Const MF_SEPARATOR = &H800&
Private Sub Form_Load()
InsertMenu GetSystemMenu(Me.hWnd, False), 0, MF_BYPOSITION Or MF_SEPARATOR, 2001, ""
InsertMenu GetSystemMenu(Me.hWnd, False), 0, MF_BYPOSITION Or MF_STRING, 2002, "About Me(&A)"
'安装子类化入口
Call Init(Me.hWnd)
End Sub
Private Sub Form_Unload(Cancel As Integer)
'卸载子类化
Call Terminate(Me.hWnd)
End Sub
Option Explicit
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const GWL_WNDPROC = (-4&)
Const WM_DESTROY = &H2
Dim PrevWndProc&
Private Const WM_SYSCOMMAND = &H112
Public Sub Init(hWnd As Long)
'子类化入口
PrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SubWndProc)
End Sub
Public Sub Terminate(hWnd As Long)
'子类化出口
Call SetWindowLong(hWnd, GWL_WNDPROC, PrevWndProc)
End Sub
Private Function SubWndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'新的窗口消息处理过程，将被插入到默认处理过程之前
If Msg = WM_DESTROY Then Terminate (Form1.hWnd)
If wParam = 2002 Then
MsgBox "About Context", vbInformation, "About..."
End If
'调用默认的窗口处理过程
SubWndProc = CallWindowProc(PrevWndProc, hWnd, Msg, wParam, lParam)
End Function
' -- 模块结束 -- '
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const GWL_WNDPROC = (-4&)
Const WM_DESTROY = &H2
Dim PrevWndProc&
Private Const WM_SYSCOMMAND = &H112
Public Sub Init(hWnd As Long)
'子类化入口
PrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SubWndProc)
End Sub
Public Sub Terminate(hWnd As Long)
'子类化出口
Call SetWindowLong(hWnd, GWL_WNDPROC, PrevWndProc)
End Sub
Private Function SubWndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'新的窗口消息处理过程，将被插入到默认处理过程之前
If Msg = WM_DESTROY Then Terminate (Form1.hWnd)
If wParam = 2002 Then
MsgBox "About Context", vbInformation, "About..."
End If
'调用默认的窗口处理过程
SubWndProc = CallWindowProc(PrevWndProc, hWnd, Msg, wParam, lParam)
End Function
' -- 模块结束 -- '
栏目列表
最新更新
python爬虫及其可视化
使用python爬取豆瓣电影短评评论内容
nodejs爬虫
Python正则表达式完全指南
爬取豆瓣Top250图书数据
shp 地图文件批量添加字段
爬虫小试牛刀（爬取学校通知公告）
【python基础】函数-初识函数
【python基础】函数-返回值
HTTP请求：requests模块基础使用必知必会
SQL SERVER中递归
2个场景实例讲解GaussDB(DWS)基表统计信息估
常用的 SQL Server 关键字及其含义
动手分析SQL Server中的事务中使用的锁
openGauss内核分析：SQL by pass & 经典执行
一招教你如何高效批量导入与更新数据
天天写SQL，这些神奇的特性你知道吗？
openGauss内核分析：执行计划生成
[IM002]Navicat ODBC驱动器管理器 未发现数据
初入Sql Server 之 存储过程的简单使用
uniapp/H5 获取手机桌面壁纸 (静态壁纸）
[前端] DNS解析与优化
为什么在js中需要添加addEventListener（）？
JS模块化系统
js通过Object.defineProperty() 定义和控制对象
这是目前我见过最好的跨域解决方案！
减少回流与重绘
减少回流与重绘
如何使用KrpanoToolJS在浏览器切图
performance.now() 与 Date.now() 对比