csubclassingthunk.cls

来自「非常漂亮的VB控件」· CLS 代码 · 共 422 行 · 第 1/2 页

            Set m_oSinkInterface = Sink
        End If
        CopyMemory VarPtr(.SinkInterface), VarPtr(Sink), 4
        '--- store API functions entry points
        .AddrCallWindowProc = pvGetProcAddr(STR_MODULE_USER32, STR_CALLWINDOWPROC)
        .AddrSetWindowLong = pvGetProcAddr(STR_MODULE_USER32, STR_SETWINDOWLONG)
        '--- first try VBA6.DLL for EbMode function
        .AddrEbMode = pvGetProcAddr(STR_MODULE_VBA6, STR_EBMODE)
        '--- then VBA5.DLL
        If .AddrEbMode = 0 Then
            .AddrEbMode = pvGetProcAddr(STR_MODULE_VBA5, STR_EBMODE)
        End If
        '--- store heap management vars
        .AddrHeapFree = pvGetProcAddr(STR_MODULE_KERNEL32, STR_HEAPFREE)
        .ProcessHeap = GetProcessHeap()
        '--- change wndproc
        .OrigWndProc = SetWindowLong(hwnd, GWL_WNDPROC, ThunkAddress)
    End With
    '--- refresh heap chunk
    CopyMemory ThunkAddress, VarPtr(m_uThunk), Len(m_uThunk)
    '--- success
    Subclass = pvRefreshMsgsBuffer
End Function

Public Function Unsubclass() As Boolean
    Dim hSaveWnd            As Long
    
    With m_uThunk.Data
    
'--- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'--- if you hit this assert then you've double subclassed a hWnd and
'---   now you are trying to unsubclass in reverse (incorrect) order
'---   note: this will NOT crash your app but please try your best to
'---   prevent this kind of double subclassing.
'---
        Debug.Assert GetWindowLong(.hwnd, GWL_WNDPROC) = 0 Or GetWindowLong(.hwnd, GWL_WNDPROC) = ThunkAddress
'---
'--- press F5 if this double subclassing is accounted for
'--- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    
        '--- state check
        If .hwnd = 0 Then
            Exit Function
        End If
        '--- if stored reference is Release'd
        Set m_oSinkInterface = Nothing
        .SinkInterface = 0
        '--- prevent message buffers being traversed
        .BeforeBufferSize = 0
        .AfterBufferSize = 0
        '--- free previous buffer
        If .MsgBuffer <> 0 Then
            HeapFree GetProcessHeap(), 0, .MsgBuffer
            .MsgBuffer = 0
        End If
        '--- try to unsubclass
        If GetWindowLong(.hwnd, GWL_WNDPROC) = ThunkAddress Then
            SetWindowLong .hwnd, GWL_WNDPROC, .OrigWndProc
            If Not m_bDontFree Then
                HeapFree GetProcessHeap(), 0, m_pThunk
                m_pThunk = 0
            End If
        End If
        '--- can call Subclass later yet again
        hSaveWnd = .hwnd
        .hwnd = 0
    End With
    '--- if heap chunk available
    If IsWindow(hSaveWnd) And m_pThunk <> 0 Then
        If m_bDontFree And Not IsNT Then
            m_uThunk.Data.ProcessHeap = 0
        End If
        '--- inactivate heap chunk
        CopyMemory m_pThunk, VarPtr(m_uThunk), Len(m_uThunk)
        m_pThunk = 0
    End If
    '--- success
    Unsubclass = True
End Function

Public Function CallOrigWndProc(ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
    If m_uThunk.Data.hwnd <> 0 Then
        CallOrigWndProc = CallWindowProc(m_uThunk.Data.OrigWndProc, m_uThunk.Data.hwnd, uMsg, wParam, lParam)
    End If
End Function

'= Private ====================================================================

Public Function pvAddMsg(aMsgs() As Long, ByVal uMsg As Long) As Boolean
    '--- if not filtered yet -> append msg
    If pvFindMsg(aMsgs, uMsg) < 0 Then
        '--- resize array
        If UBound(aMsgs) < 0 Then
            ReDim aMsgs(0 To 0)
        Else
            ReDim Preserve aMsgs(0 To UBound(aMsgs) + 1)
        End If
        '--- append new msg
        aMsgs(UBound(aMsgs)) = uMsg
        '--- success (or failure)
        pvAddMsg = pvRefreshMsgsBuffer()
    End If
End Function

Public Function pvRemoveMsg(aMsgs() As Long, ByVal uMsg As Long) As Boolean
    Dim lIdx            As Long
    
    '--- if msg present
    lIdx = pvFindMsg(aMsgs, uMsg)
    If lIdx >= 0 Then
        If UBound(aMsgs) > 0 Then
            '--- shift msgs
            Do While lIdx < UBound(aMsgs)
                aMsgs(lIdx) = aMsgs(lIdx + 1)
                lIdx = lIdx + 1
            Loop
            ReDim Preserve aMsgs(0 To UBound(aMsgs) - 1)
        Else
            '--- last msgs removed
            ReDim aMsgs(-1 To -1)
        End If
        '--- success (or failure)
        pvRemoveMsg = pvRefreshMsgsBuffer()
    End If
End Function

Private Function pvFindMsg(aMsgs() As Long, ByVal uMsg As Long)
    Dim lIdx            As Long
    
    pvFindMsg = -1
    For lIdx = 0 To UBound(aMsgs)
        If aMsgs(lIdx) = uMsg Then
            pvFindMsg = lIdx
            Exit Function
        End If
    Next
End Function

Private Function pvRefreshMsgsBuffer() As Boolean
    Dim lBeforeSize     As Long
    Dim lAfterSize      As Long
    
    With m_uThunk.Data
        '--- init local vars
        lBeforeSize = UBound(m_aBeforeMsgs) + 1
        lAfterSize = UBound(m_aAfterMsgs) + 1
        '--- free previous buffer
        If .MsgBuffer <> 0 Then
            HeapFree GetProcessHeap(), 0, .MsgBuffer
            .MsgBuffer = 0
        End If
        '--- if any msg -> allocate new buffer
        If lBeforeSize + lAfterSize > 0 Then
            .MsgBuffer = HeapAlloc(GetProcessHeap(), 0, 4 * (lBeforeSize + lAfterSize))
            '--- fill new buffer: part 1
            If lBeforeSize > 0 Then
                CopyMemory .MsgBuffer, VarPtr(m_aBeforeMsgs(0)), 4 * lBeforeSize
            End If
            '--- fill new buffer: part 2
            If lAfterSize > 0 Then
                CopyMemory .MsgBuffer + 4 * lBeforeSize, VarPtr(m_aAfterMsgs(0)), 4 * lAfterSize
            End If
        End If
        '--- handle special case: if 'all msgs' -> size = -1
        .BeforeBufferSize = IIf(AllBeforeMsgs, -1, lBeforeSize)
        .AfterBufferSize = IIf(AllAfterMsgs, -1, lAfterSize)
    End With
    '--- refresh heap chunk
    CopyMemory ThunkAddress, VarPtr(m_uThunk), Len(m_uThunk)
    '--- success
    pvRefreshMsgsBuffer = True
End Function

Private Function pvGetProcAddr(sModule As String, sFunction As String) As Long
    pvGetProcAddr = GetProcAddress(GetModuleHandle(sModule), sFunction)
End Function

Private Property Get IsNT() As Boolean
    Dim uVer            As OSVERSIONINFO
    
    uVer.dwOSVersionInfoSize = Len(uVer)
    If GetVersionEx(uVer) Then
        IsNT = uVer.dwPlatformId = VER_PLATFORM_WIN32_NT
    End If
End Property

Private Sub Class_Initialize()
    Dim lIdx            As Long
    Dim vOpcode         As Variant
    
    '--- extract code
    For Each vOpcode In Split(STR_ASM_OPCODES)
        m_uThunk.Code(lIdx) = vOpcode
        lIdx = lIdx + 1
    Next
    '--- create "empty" arrays
    ReDim m_aBeforeMsgs(-1 To -1)
    ReDim m_aAfterMsgs(-1 To -1)
    #If DebugMode Then
        DebugInit m_sDebugID, MODULE_NAME
    #End If
End Sub

Private Sub Class_Terminate()
    Unsubclass
    #If DebugMode Then
        DebugTerm m_sDebugID
    #End If
End Sub