subclass.bas

来自「100个vb编程实例,什么都有」· BAS 代码 · 共 66 行

Attribute VB_Name = "mSubClass"
Option Explicit


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)
    MsgBox "Unable to successfully subclass &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)
      
    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