Crazy D
May 1st, 2000, 01:53 PM
Hi,
This is the code I'm currently using in my project.,
No time to clean it up, or to make the comments English (they're Dutch right now....)
I hope the code is enough self-explaining....
in a module:
'nodig voor het resizen van de window...
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MINMAXINFO
ptReserved As POINTAPI
ptMaxSize As POINTAPI
ptMaxPosition As POINTAPI
ptMinTrackSize As POINTAPI
ptMaxTrackSize As POINTAPI
End Type
' roep de originele windowproc aan
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' om onze subclass als windowproc te registreren
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
' pointer naar een MINMAXINFO type kopieëren naar een variable van dat type
Private Declare Sub CopyMemoryToMinMaxInfo Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As MINMAXINFO, ByVal hpvSource As Long, ByVal cbCopy As Long)
' variable MINMAXINFO terug kopieëren naar de pointer
Private Declare Sub CopyMemoryFromMinMaxInfo Lib "kernel32" Alias "RtlMoveMemory" (ByVal hpvDest As Long, hpvSource As MINMAXINFO, ByVal cbCopy As Long)
' constanten voor de subclass
Private Const GWL_WNDPROC = -4
' om het netjes te doen, vangen we ook deze msg's af om de subclass op te heffen...
Private Const WM_CLOSE = &H10
Private Const WM_DESTROY = &H2
' de message die we willen afvangen...
Private Const WM_GETMINMAXINFO = &H24
' om de properties te zetten...
' hiermee bewaren we de width en height, en de originele windowproc als properties van de form welke we subclassen
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
' constanten voor de property namen
Private Const AUTOTAAL_PROP_ORI_WINDOW_PROC = "_AUTOTAAL_WINDOWPROC_WNDPROC_RESIZE_"
Private Const AUTOTAAL_PROPERTY_ORI_WIDTH = "_AUTOTAAL_WINDOWPROC_WIDTH_"
Private Const AUTOTAAL_PROPERTY_ORI_HEIGHT = "_AUTOTAAL_WINDOWPROC_HEIGHT_"
' is de window een window
Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
Dim l As Long ' temp long
Private Function MyIsWindow(hWnd As Long) As Boolean
MyIsWindow = ((hWnd <> 0) And (IsWindow(hWnd) <> 0))
End Function
' HookResize: voeg de hWnd toe
Public Sub HookResize(ByVal hWnd As Long, ByVal MinWidth As Integer, ByVal MinHeight As Integer)
l = 0
' even controleren of de handle een window is
If Not MyIsWindow(hWnd) Then
Err.Raise vbObjectError + 1002, "modSubclass::HookResize", "hWnd is geen (geldige) window handle"
Exit Sub
End If
' even controleren of de properties al bestaan
l = GetProp(hWnd, AUTOTAAL_PROP_ORI_WINDOW_PROC)
If l <> 0 Then
' hij werd al gesubclassed.. even unhooken
Call UnhookResize(hWnd)
End If
' originele windowproc vervangen door de onze en opslaan..
l = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProcResize)
Call SetProp(hWnd, AUTOTAAL_PROP_ORI_WINDOW_PROC, l)
' minwidth en minheight ook opslaan als properties
Call SetProp(hWnd, AUTOTAAL_PROPERTY_ORI_WIDTH, MinWidth)
Call SetProp(hWnd, AUTOTAAL_PROPERTY_ORI_HEIGHT, MinHeight)
End Sub
Public Sub UnhookResize(ByVal hWnd As Long)
' even controleren
If Not MyIsWindow(hWnd) Then Exit Sub
' originele windowproc ophalen en terugzetten
l = GetProp(hWnd, AUTOTAAL_PROP_ORI_WINDOW_PROC)
Call SetWindowLong(hWnd, GWL_WNDPROC, l)
' en de properties verwijderen
Call RemoveProp(hWnd, AUTOTAAL_PROP_ORI_WINDOW_PROC)
Call RemoveProp(hWnd, AUTOTAAL_PROPERTY_ORI_WIDTH)
Call RemoveProp(hWnd, AUTOTAAL_PROPERTY_ORI_HEIGHT)
End Sub
' DE subclass info
Public Function WindowProcResize(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
l = 0
' de window wordt geresized
If uMsg = WM_GETMINMAXINFO Then
Dim MinMax As MINMAXINFO
Static Width As Integer, Height As Integer
' even de width en height uitlezen - properties worden gevuld met waardes in pixels
Width = GetProp(hWnd, AUTOTAAL_PROPERTY_ORI_WIDTH)
Height = GetProp(hWnd, AUTOTAAL_PROPERTY_ORI_HEIGHT)
' lParam is een pointer naar de minmaxinfo structure, even kopieeren
CopyMemoryToMinMaxInfo MinMax, lParam, Len(MinMax)
' waardes zetten
MinMax.ptMinTrackSize.X = Width
MinMax.ptMinTrackSize.Y = Height
' en weer terug kopieeren
CopyMemoryFromMinMaxInfo lParam, MinMax, Len(MinMax)
' windows zeggen dat wij deze msg hebben afgehandeld
WindowProcResize = 1
' Exit Function
' de window is aan het sluiten...
' om het netjes te doen, vangen we deze msg ook hier af, zodat als om d'een of d'andere reden
' de unsubclass method niet wordt aangeroepen in de class, dan ruimen we in ieder geval netjes op :-)
ElseIf uMsg = WM_CLOSE Or uMsg = WM_DESTROY Then
Call UnhookResize(hWnd)
Else ' en in alle andere gevalle, sturen we de msg door
' even de originele proc ophalen en aanroepen
l = GetProp(hWnd, AUTOTAAL_PROP_ORI_WINDOW_PROC)
WindowProcResize = CallWindowProc(l, hWnd, uMsg, wParam, lParam)
End If
End Function
In a usercontrols (I used a usercontrol cause that was easier, can be a class too)
' aanroepen vanuit de form_load
' width en height zijn in twips!!
Public Sub Subclass(hOwner As Object, Optional MinWidth As Integer = 12000, Optional MinHeight As Integer = 9000)
' even controleren: is het parent object een MDI form of een gewone form...
If (Not (TypeOf hOwner Is MDIForm)) And (Not (TypeOf hOwner Is Form)) Then
Err.Raise vbObjectError + 1001, "A_Resize::Subclass", "Owner Object is geen (MDI)Form!"
Exit Sub
End If
' width en height omrekenen naar pixels...
MinWidth = MinWidth \ Screen.TwipsPerPixelX
MinHeight = MinHeight \ Screen.TwipsPerPixelY
Call HookResize(hOwner.hWnd, MinWidth, MinHeight)
End Sub
' unload
Public Sub UnSubclass(ByVal hWnd As Long)
Call UnhookResize(hWnd)
End Sub
Call it like
controlname.subclass me, me.width, me.height
If you have quetions, maybe I have more time later today to answer.
Hope this helps.
This is the code I'm currently using in my project.,
No time to clean it up, or to make the comments English (they're Dutch right now....)
I hope the code is enough self-explaining....
in a module:
'nodig voor het resizen van de window...
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MINMAXINFO
ptReserved As POINTAPI
ptMaxSize As POINTAPI
ptMaxPosition As POINTAPI
ptMinTrackSize As POINTAPI
ptMaxTrackSize As POINTAPI
End Type
' roep de originele windowproc aan
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' om onze subclass als windowproc te registreren
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
' pointer naar een MINMAXINFO type kopieëren naar een variable van dat type
Private Declare Sub CopyMemoryToMinMaxInfo Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As MINMAXINFO, ByVal hpvSource As Long, ByVal cbCopy As Long)
' variable MINMAXINFO terug kopieëren naar de pointer
Private Declare Sub CopyMemoryFromMinMaxInfo Lib "kernel32" Alias "RtlMoveMemory" (ByVal hpvDest As Long, hpvSource As MINMAXINFO, ByVal cbCopy As Long)
' constanten voor de subclass
Private Const GWL_WNDPROC = -4
' om het netjes te doen, vangen we ook deze msg's af om de subclass op te heffen...
Private Const WM_CLOSE = &H10
Private Const WM_DESTROY = &H2
' de message die we willen afvangen...
Private Const WM_GETMINMAXINFO = &H24
' om de properties te zetten...
' hiermee bewaren we de width en height, en de originele windowproc als properties van de form welke we subclassen
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
' constanten voor de property namen
Private Const AUTOTAAL_PROP_ORI_WINDOW_PROC = "_AUTOTAAL_WINDOWPROC_WNDPROC_RESIZE_"
Private Const AUTOTAAL_PROPERTY_ORI_WIDTH = "_AUTOTAAL_WINDOWPROC_WIDTH_"
Private Const AUTOTAAL_PROPERTY_ORI_HEIGHT = "_AUTOTAAL_WINDOWPROC_HEIGHT_"
' is de window een window
Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
Dim l As Long ' temp long
Private Function MyIsWindow(hWnd As Long) As Boolean
MyIsWindow = ((hWnd <> 0) And (IsWindow(hWnd) <> 0))
End Function
' HookResize: voeg de hWnd toe
Public Sub HookResize(ByVal hWnd As Long, ByVal MinWidth As Integer, ByVal MinHeight As Integer)
l = 0
' even controleren of de handle een window is
If Not MyIsWindow(hWnd) Then
Err.Raise vbObjectError + 1002, "modSubclass::HookResize", "hWnd is geen (geldige) window handle"
Exit Sub
End If
' even controleren of de properties al bestaan
l = GetProp(hWnd, AUTOTAAL_PROP_ORI_WINDOW_PROC)
If l <> 0 Then
' hij werd al gesubclassed.. even unhooken
Call UnhookResize(hWnd)
End If
' originele windowproc vervangen door de onze en opslaan..
l = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProcResize)
Call SetProp(hWnd, AUTOTAAL_PROP_ORI_WINDOW_PROC, l)
' minwidth en minheight ook opslaan als properties
Call SetProp(hWnd, AUTOTAAL_PROPERTY_ORI_WIDTH, MinWidth)
Call SetProp(hWnd, AUTOTAAL_PROPERTY_ORI_HEIGHT, MinHeight)
End Sub
Public Sub UnhookResize(ByVal hWnd As Long)
' even controleren
If Not MyIsWindow(hWnd) Then Exit Sub
' originele windowproc ophalen en terugzetten
l = GetProp(hWnd, AUTOTAAL_PROP_ORI_WINDOW_PROC)
Call SetWindowLong(hWnd, GWL_WNDPROC, l)
' en de properties verwijderen
Call RemoveProp(hWnd, AUTOTAAL_PROP_ORI_WINDOW_PROC)
Call RemoveProp(hWnd, AUTOTAAL_PROPERTY_ORI_WIDTH)
Call RemoveProp(hWnd, AUTOTAAL_PROPERTY_ORI_HEIGHT)
End Sub
' DE subclass info
Public Function WindowProcResize(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
l = 0
' de window wordt geresized
If uMsg = WM_GETMINMAXINFO Then
Dim MinMax As MINMAXINFO
Static Width As Integer, Height As Integer
' even de width en height uitlezen - properties worden gevuld met waardes in pixels
Width = GetProp(hWnd, AUTOTAAL_PROPERTY_ORI_WIDTH)
Height = GetProp(hWnd, AUTOTAAL_PROPERTY_ORI_HEIGHT)
' lParam is een pointer naar de minmaxinfo structure, even kopieeren
CopyMemoryToMinMaxInfo MinMax, lParam, Len(MinMax)
' waardes zetten
MinMax.ptMinTrackSize.X = Width
MinMax.ptMinTrackSize.Y = Height
' en weer terug kopieeren
CopyMemoryFromMinMaxInfo lParam, MinMax, Len(MinMax)
' windows zeggen dat wij deze msg hebben afgehandeld
WindowProcResize = 1
' Exit Function
' de window is aan het sluiten...
' om het netjes te doen, vangen we deze msg ook hier af, zodat als om d'een of d'andere reden
' de unsubclass method niet wordt aangeroepen in de class, dan ruimen we in ieder geval netjes op :-)
ElseIf uMsg = WM_CLOSE Or uMsg = WM_DESTROY Then
Call UnhookResize(hWnd)
Else ' en in alle andere gevalle, sturen we de msg door
' even de originele proc ophalen en aanroepen
l = GetProp(hWnd, AUTOTAAL_PROP_ORI_WINDOW_PROC)
WindowProcResize = CallWindowProc(l, hWnd, uMsg, wParam, lParam)
End If
End Function
In a usercontrols (I used a usercontrol cause that was easier, can be a class too)
' aanroepen vanuit de form_load
' width en height zijn in twips!!
Public Sub Subclass(hOwner As Object, Optional MinWidth As Integer = 12000, Optional MinHeight As Integer = 9000)
' even controleren: is het parent object een MDI form of een gewone form...
If (Not (TypeOf hOwner Is MDIForm)) And (Not (TypeOf hOwner Is Form)) Then
Err.Raise vbObjectError + 1001, "A_Resize::Subclass", "Owner Object is geen (MDI)Form!"
Exit Sub
End If
' width en height omrekenen naar pixels...
MinWidth = MinWidth \ Screen.TwipsPerPixelX
MinHeight = MinHeight \ Screen.TwipsPerPixelY
Call HookResize(hOwner.hWnd, MinWidth, MinHeight)
End Sub
' unload
Public Sub UnSubclass(ByVal hWnd As Long)
Call UnhookResize(hWnd)
End Sub
Call it like
controlname.subclass me, me.width, me.height
If you have quetions, maybe I have more time later today to answer.
Hope this helps.