Projects

Owner Draw Combo and List Box Control

April 12, 2007 by Java

Browsing SubClassMod.bas (2.90 KB)

Attribute VB_Name = "SubClassMod"

Private Const WM_DESTROY = &H2
Private Const WM_ERASEBKGND = &H14

Private Type SUBCLASSWINDOW
    hWnd As Long
    defProc As Long
End Type

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 scWindow() As SUBCLASSWINDOW

Public Sub SubClassWnd(ByVal hWnd As Long)
Dim scWnd As SUBCLASSWINDOW
    scWnd.hWnd = hWnd
    On Error Resume Next
    ReDim Preserve scWindow(UBound(scWindow) + 1)
    If Err Then ReDim scWindow(1)
    scWnd.defProc = SubClass(scWnd.hWnd)
    scWindow(UBound(scWindow)) = scWnd
End Sub


Private Function SubClass(hWnd As Long) As Long
Dim defWindowProc As Long
On Error Resume Next
    defWindowProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
    SubClass = defWindowProc
End Function


Public Sub UnSubClassWnd(ByVal hWnd As Long)
On Error Resume Next
Dim i As Integer, scWnd As SUBCLASSWINDOW, found As Integer
    found = -1
    For i = 1 To UBound(scWindow)
    If scWindow(i).hWnd = hWnd Then
            scWnd = scWindow(i)
            found = i
        End If
    Next
    If found <> -1 Then
        UnSubClass hWnd, scWnd.defProc
        If found < UBound(scWindow) Then
            For i = found To UBound(scWindow) - 1
                scWindow(i) = scWindow(i + 1)
            Next
        End If
        ReDim Preserve scWindow(UBound(scWindow) - 1)
    End If
End Sub


Public Sub UnSubClassWndAll()
On Error Resume Next
    If UBound(scWindow) < 1 Then Exit Sub
    If Err <> 0 Then Exit Sub
    Dim i As Integer
    For i = 1 To UBound(scWindow)
        If scWindow(i).hWnd > 0 Then UnSubClass scWindow(i).hWnd, scWindow(i).defProc
    Next i
    ReDim scWindow(0)
End Sub


Private Sub UnSubClass(hWnd As Long, PrevDefProc As Long)
    SetWindowLong hWnd, GWL_WNDPROC, PrevDefProc
End Sub


Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim i As Integer, bWndFound As Boolean, scWnd As SUBCLASSWINDOW
On Error Resume Next
    For i = 1 To UBound(scWindow)
        If scWindow(i).hWnd = hWnd Then
            bWndFound = True
            scWnd = scWindow(i)
            Exit For
        End If
    Next i
    If bWndFound Then
        Select Case uMsg
            Case WM_ERASEBKGND
                Dim Rct As RECT
                GetClientRect hWnd, Rct
                FillRect wParam, Rct, m_EraseBkgndColor
                WindowProc = 1
            Case WM_DESTROY
                UnSubClassWnd hWnd
                WindowProc = CallWindowProc(scWnd.defProc, hWnd, uMsg, wParam, lParam)
            Case Else
                WindowProc = CallWindowProc(scWnd.defProc, hWnd, uMsg, wParam, lParam)
        End Select
    End If
End Function

Download SubClassMod.bas

Back to file list

---

Back to project page