fsub.bas

来自「提供进程监视[包括启动参数] 进程检测[包括启动参数] 网络连接检测 」· BAS 代码 · 共 68 行

Attribute VB_Name = "mSub"
'Option Explicit

Private Const WM_NCDESTROY = &H82
Private Const GWL_WNDPROC = (-4)
Private Const OLDWNDPROC = "OldWndProc"

Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal _
        hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal _
        hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal _
        hwnd As Long, ByVal lpString As String) 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 Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
        (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal uMsg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long

Public Function SubClass(hwnd As Long) As Boolean
    Dim lpfnOld As Long
    Dim fSuccess As Boolean
  
    If (GetProp(hwnd, OLDWNDPROC) = 0) Then
        lpfnOld = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WndProc)
        If lpfnOld Then
            fSuccess = SetProp(hwnd, OLDWNDPROC, lpfnOld)
        End If
    End If
  
    If fSuccess Then
        SubClass = True
    Else
        If lpfnOld Then Call UnSubClass(hwnd)
        MsgBox "设置失败! &H" & Hex(hwnd), vbCritical
    End If
End Function

Public Function UnSubClass(hwnd As Long) As Boolean
    Dim lpfnOld As Long
  
    lpfnOld = GetProp(hwnd, OLDWNDPROC)
    If lpfnOld Then
        If RemoveProp(hwnd, OLDWNDPROC) Then
            UnSubClass = SetWindowLong(hwnd, GWL_WNDPROC, lpfnOld)
        End If
    End If
End Function

Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As _
        Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case WM_SHNOTIFY        '处理系统消息通告函数
            'Call Form1.NotificationReceipt(wParam, lParam)
            Dim npid As Long
            PostMessage mainHwnd, &H404, ByVal wParam, ByVal lParam
        Case WM_NCDESTROY
            Call UnSubClass(hwnd)
            MsgBox "Unubclassed &H" & Hex(hwnd), vbCritical, "WndProc Error"
    End Select
    
    WndProc = CallWindowProc(GetProp(hwnd, OLDWNDPROC), hwnd, uMsg, wParam, lParam)
End Function