modhook.bas

来自「电话本信息 基本上实现电话功能 自己下载侃侃吧」· BAS 代码 · 共 76 行

Attribute VB_Name = "FormHOOK"
Option Explicit

Type POINTAPI
        X As Long
        y As Long
End Type

Type MINMAXINFO
        ptReserved As POINTAPI
        ptMaxSize As POINTAPI
        ptMaxPosition As POINTAPI
        ptMinTrackSize As POINTAPI
        ptMaxTrackSize As POINTAPI
End Type

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 Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)

Public Const GWL_WNDPROC = (-4)
Public Const WM_GETMINMAXINFO = &H24

Dim OldProc As Long
Dim mhWnd As Long

'==================================================
'回调
Function WinProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
                  
'    Select Case wMsg
'        Case WM_GETMINMAXINFO
'            Dim MinMax As MINMAXINFO
'
'            CopyMemory MinMax, ByVal lParam, Len(MinMax)
'
'            MinMax.ptMinTrackSize.x = 567
'            MinMax.ptMinTrackSize.y = 250
''            MinMax.ptMaxTrackSize.x = 808
''            MinMax.ptMaxTrackSize.y = 250
'
'            CopyMemory ByVal lParam, MinMax, Len(MinMax)
'
'            WinProc& = 1
'            Exit Function
'    End Select
'
'    Debug.Print "wMsg=" & wMsg & " wParam=" & wParam & " lParam=" & lParam
    WinProc = CallWindowProc(OldProc, hwnd, wMsg, wParam, lParam)
End Function
'==================================================


'==================================================
'挂钩
Sub Hook(ByVal nhWnd As Long)

    If OldProc <> 0 Then Exit Sub
    
    mhWnd = nhWnd
    
    OldProc = SetWindowLong(nhWnd, GWL_WNDPROC, AddressOf WinProc)

End Sub
'==================================================


'==================================================
'脱钩
Sub UnHook()
    If OldProc = 0 Then Exit Sub
    SetWindowLong mhWnd, GWL_WNDPROC, OldProc
    OldProc = 0
End Sub
'==================================================