'API函数
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
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
'定义常数
Public Const GWL_WNDPROC = (-4)
Public Const HT_CAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
'全局变量,存放控件标志性数据
Public preWinProc As Long
'本函数就是用来接收子分类时截取的消息的
Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Form1.NewCheck.Value = vbChecked Then
wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
Exit Function
End If
'截取下来的消息存放在msg参数中.
If (Msg = WM_NCLBUTTONDOWN) And (wParam = HT_CAPTION) Then
'检测到鼠标消息,这里就可以加入我们的处理代码
'如果这儿不加入任何代码,则相当于吃掉了这条消息.
Else
'如果我们不是我们需要处理的消息,则将之送回原来的程序.
wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End If
End Function
'======================================================'以下代码在窗体中:
Public WithEvents NewCheck As CheckBox
Private Sub NewCheck_Click()
If NewCheck.Value = vbUnchecked Then
NewCheck.Caption = "禁止移动"
Else: NewCheck.Caption = "允许移动"
End If
End Sub
Private Sub subclass()
Dim ret As Long
'记录Window Procedure的地址
preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
'开始截取消息,并将消息交给wndproc过程处理.
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf wndproc)
End Sub
Private Sub EndSubclass()
Dim ret As Long
'取消消息截取,结束子分类过程.
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc)
End Sub
Private Sub Form_Load()
'这里动态加入一个CheckBox,不用在设计时添加
If NewCheck Is Nothing Then
Set NewCheck = Controls.Add("VB.CheckBox", "chkNew", Me)
With NewCheck
.Move 50, 50, 1500, 255
.Caption = "禁止移动"
.Visible = True
End With
End If
Call subclass
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call EndSubclass
End Sub