gxmsubclass.cls

一款Grid表格控件源代码,非常棒.不下你一定会后悔

    m_lTData(47) = &H4589145D
    m_lTData(48) = &HC4836124
    m_lTData(49) = &H1862FF04
    m_lTData(50) = &H35E30F8B
    m_lTData(51) = &HA78C985
    m_lTData(52) = &H8B04C783
    m_lTData(53) = &HAFF22845
    m_lTData(54) = &H73FF2775
    m_lTData(55) = &H1C53FF28
    m_lTData(56) = &H438D1F75
    m_lTData(57) = &H144D8D34
    m_lTData(58) = &H1C458D50
    m_lTData(59) = &HFF3075FF
    m_lTData(60) = &H75FF2C75
    m_lTData(61) = &H873FF28
    m_lTData(62) = &HFF525150
    m_lTData(63) = &H53FF2073
    m_lTData(64) = &HC328&
    
    If m_bIsNt Then
        'Store CallWindowProcW function address in the thunk data
        m_lTData(IDX_CWP) = ReturnAddr("user32", "CallWindowProcW")
        'Store the SetWindowLongw function address in the thunk data
        m_lTData(IDX_SWL) = ReturnAddr("user32", "SetWindowLongW")
    Else
        'Store CallWindowProcA function address in the thunk data
        m_lTData(IDX_CWP) = ReturnAddr("user32", "CallWindowProcA")
        'Store the SetWindowLongA function address in the thunk data
        m_lTData(IDX_SWL) = ReturnAddr("user32", "SetWindowLongA")
    End If
    
    'Store the VirtualFree function address in the thunk data
    m_lTData(IDX_FREE) = ReturnAddr("kernel32", "VirtualFree")
    'Store the IsBadCodePtr function address in the thunk data
    m_lTData(IDX_BADPTR) = ReturnAddr("kernel32", "IsBadCodePtr")

End Sub

Public Sub AddMessage(ByVal lHwnd As Long, _
                      ByVal uMsg As eMsg, _
                      Optional ByVal eWhen As eMsgWhen)
'Add the message value to the window handle's specified callback table

    'Ensure that the thunk hasn't already released its memory
    If IsBadCodePtr(MapHandle(lHwnd)) = 0 Then
        'Add the message to the before table
        If eWhen And MSG_BEFORE Then
            AddMsg uMsg, IDX_BTABLE
        End If
        'Add the message to the after table
        If eWhen And MSG_AFTER Then
            AddMsg uMsg, IDX_ATABLE
        End If
    End If

End Sub

Public Sub DeleteMessage(ByVal lHwnd As Long, _
                         ByVal uMsg As eMsg, _
                         Optional ByVal eWhen As eMsgWhen)
'Delete the message value from the window handle's specified callback table

    'Ensure that the thunk hasn't already released its memory
    If IsBadCodePtr(MapHandle(lHwnd)) = 0 Then
        If eWhen And MSG_BEFORE Then
            DelMsg uMsg, IDX_BTABLE
        End If
        If eWhen And MSG_AFTER Then
            DelMsg uMsg, IDX_ATABLE
        End If
    End If
  
End Sub

Public Function CallOldWndProc(ByVal lHwnd As Long, _
                               ByVal uMsg As Long, _
                               ByVal wParam As Long, _
                               ByVal lParam As Long) As Long
'Call the original WndProc

    'Ensure that the thunk hasn't already released its memory
    If IsBadCodePtr(MapHandle(lHwnd)) = 0 Then
        'Call the original WndProc of the passed window handle parameter
        If m_bIsNt Then
            CallOldWndProc = CallWindowProcW(p_CAddress(IDX_WNDPROC), lHwnd, uMsg, wParam, lParam)
        Else
            CallOldWndProc = CallWindowProcA(p_CAddress(IDX_WNDPROC), lHwnd, uMsg, wParam, lParam)
        End If
    End If

End Function

Private Sub AddMsg(ByVal uMsg As Long, _
                   ByVal nTable As Long)
'Add the message to the specified table of the window handle

Dim lCount As Long
Dim lBase  As Long
Dim i      As Long

    'Remember m_lResMem so that we can restore its value on exit
    lBase = m_lResMem
    'Map p_CAddress() to the specified table
    m_lResMem = p_CAddress(nTable)

    'If ALL_MESSAGES are being added to the table
    If uMsg = ALL_MESSAGES Then
        'Set the table entry count to ALL_MESSAGES
        lCount = ALL_MESSAGES
    Else
        'Get the current table entry count
        lCount = p_CAddress(0)
        If lCount >= MSG_ENTRIES Then
            'Check for message table overflow
            ErrorCond "AddMsg", "Message table overflow. Max message entries exceeded."
            GoTo Handler
        End If
        'Loop through the table entries
        For i = 1 To lCount
            'If the element is free...
            If p_CAddress(i) = 0 Then
                p_CAddress(i) = uMsg
                GoTo Handler
            'If the message is already in the table
            ElseIf p_CAddress(i) = uMsg Then
                GoTo Handler
            End If
        Next i
        'On drop through: i = lCount + 1, the new table entry count
        lCount = i
        p_CAddress(lCount) = uMsg
    End If
    'Store the message in the appended table entry
    p_CAddress(0) = lCount
  
Handler:
    m_lResMem = lBase

End Sub

Private Sub DelMsg(ByVal uMsg As Long, _
                   ByVal nTable As Long)
'Delete the message from the specified table of the window handle

Dim lCount As Long
Dim lBase  As Long
Dim i      As Long

    'Remember m_lResMem so that we can restore its value on exit
    lBase = m_lResMem
    'Map p_CAddress() to the specified table
    m_lResMem = p_CAddress(nTable)

    'If ALL_MESSAGES are being deleted from the table
    If uMsg = ALL_MESSAGES Then
        'Zero the table entry count
        p_CAddress(0) = 0
    Else
        'Get the table entry count
        lCount = p_CAddress(0)
        'Loop through the table entries
        For i = 1 To lCount
            If p_CAddress(i) = uMsg Then
                p_CAddress(i) = 0
                GoTo Handler
            End If
        Next i
        ErrorCond "DelMsg", "Message &H" & Hex$(uMsg) & " not found in table"
    End If
  
Handler:
    m_lResMem = lBase

End Sub

Private Sub ErrorCond(ByVal sRoutine As String, _
                      ByVal sMsg As String)
'Error handler

  App.LogEvent TypeName(Me) & "." & sRoutine & ": " & sMsg, vbLogEventTypeError
  MsgBox sMsg & ".", vbExclamation + vbApplicationModal, "Error in " & TypeName(Me) & "." & sRoutine

End Sub

Private Function ReturnAddr(ByVal sDLL As String, _
                            ByVal sProc As String) As Long
'Return the address of the specified DLL/procedure

    'Get the specified procedure address
    If m_bIsNt Then
        ReturnAddr = GetProcAddress(GetModuleHandleW(StrPtr(sDLL)), sProc)
    Else
        ReturnAddr = GetProcAddress(GetModuleHandleA(sDLL), sProc)
    End If
    'In the IDE, validate that the procedure address was located
    Debug.Assert ReturnAddr
  
End Function

Private Function MapHandle(ByVal lHwnd As Long) As Long
'Map p_CAddress() to the thunk address for the specified window handle

    'Ensure that subclassing has been started
    If m_cWndHnd Is Nothing Then
        ErrorCond "MapHandle", "Subclassing hasn't been started"
    Else
        On Error GoTo Handler
        'Catch unsubclassed window handles
        m_lResMem = m_cWndHnd("h" & lHwnd)
        'Get the thunk address
        MapHandle = m_lResMem
    End If
  
Exit Function

Handler:
    ErrorCond "MapHandle", "Window handle isn't subclassed"

End Function

Public Sub UnSubclass(ByVal lHwnd As Long)
'UnSubclass the specified window handle

    'Ensure that subclassing has been started
    If m_cWndHnd Is Nothing Then
        ErrorCond "UnSubclass", "Window handle isn't subclassed"
    Else
        'Ensure that the thunk hasn't already released its memory
        If IsBadCodePtr(MapHandle(lHwnd)) = 0 Then
            'Set the shutdown indicator
            p_CAddress(IDX_SHUTDOWN) = -1
            'Delete all before messages
            DelMsg ALL_MESSAGES, IDX_BTABLE
            'Delete all after messages
            DelMsg ALL_MESSAGES, IDX_ATABLE
        End If
        'Remove the specified window handle from the collection
        m_cWndHnd.Remove "h" & lHwnd
    End If

End Sub

Public Sub Terminate()
'Terminate all subclassing

Dim i As Long

    If Not (m_cWndHnd Is Nothing) Then
        'Ensure that subclassing has been started
        With m_cWndHnd
            'Loop through the collection of window handles in reverse order
            For i = .Count To 1 Step -1
                'Get the thunk address
                m_lResMem = .Item(i)
                'Ensure that the thunk hasn't already released its memory
                If IsBadCodePtr(m_lResMem) = 0 Then
                    UnSubclass p_CAddress(IDX_HWND)
                End If
            Next i
        End With
        'Destroy the hWnd/thunk-address collection
        Set m_cWndHnd = Nothing
    End If
  
End Sub

Private Sub Class_Terminate()
    Terminate
End Sub