subclass.bas

来自「可以骗过系统或杀毒软件的软件（病毒） 用vb写的 欢迎测试」· BAS 代码 · 共 60 行

Attribute VB_Name = "mSubClass"

Private Const WM_NCDESTROY = &H82

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 Const GWL_WNDPROC = (-4)

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

Private Const OLDWNDPROC = "OldWndProc"

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)
  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 Usa.NotificationReceipt(wParam, lParam)
      
    Case WM_NCDESTROY
      Call UnSubClass(hWnd)
  End Select
  
  WndProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
  
End Function