模块:
Option Explicit
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lparam As Any) As Long
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lparam As Long) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Const HCBT_ACTIVATE = 5
Public Const WH_CBT = 5
Public hHook As Long
Public Sub EnableHook()
If hHook = 0 Then
hHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, App.ThreadID)
End If
End Sub
Public Sub FreeHook()
If hHook <> 0 Then
Call UnhookWindowsHookEx(hHook)
hHook = 0
End If
End Sub
Public Function HookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
If nCode < 0 Then
HookProc = CallNextHookEx(hHook, nCode, wParam, lparam)
Exit Function
End If
If nCode = HCBT_ACTIVATE Then
Dim str5 As String
Dim len5 As Long, i As Long
str5 = String(255, 0)
len5 = 256
i = GetWindowText(wParam, str5, len5)
str5 = Left(str5, InStr(1, str5, Chr(0)) - 1)
'设置颜色对话框居中显示
If str5 = "颜色" Then
Dim RT As RECT
GetWindowRect wParam, RT
Dim mWidth As Long
Dim mHeight As Long
Dim mLeft As Long
Dim mTop As Long
mWidth = RT.Right - RT.Left
mHeight = RT.Bottom - RT.Top
mLeft = Screen.Width \ Screen.TwipsPerPixelX
mLeft = (mLeft - mWidth) \ 2
mTop = Screen.Height \ Screen.TwipsPerPixelY
mTop = (mTop - mHeight) \ 2
MoveWindow wParam, mLeft, mTop, mWidth, mHeight, True
End If
End If
HookProc = 0 '令待完成的动作继续完成,若为1,则取消原本要完成的动作
End Function
窗体,只有一个按钮和一个CommonDialog控件:
Option Explicit
Private Sub Command1_Click()
EnableHook
CommonDialog1.ShowColor
FreeHook
End Sub