-
I`m trying to subclass wm_size event .. (trying to stop resizing when too small)
anyways .. my whole app crashes .. here`s the code ...
.bas
Option Explicit
'messages to intercept
Public Const WM_SIZE = &H5
Public Const WM_PAINT = &HF
Public Const GWL_WNDPROC = (-4) 'subclassing routine
Public OldProc As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long)
Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
---------------------------------------------------------
Public Function WndProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
If wMsg = WM_SIZE Then
PostMessage hwnd, WM_PAINT, 0, 0
MsgBox("resized")
'don`t do anything .... just passes along
End If
'pass other messages
WndProc = CallWindowProc(OldProc, hwnd, wMsg, wParam, lParam)
End Function
-------------------------------------------------
form
Public Sub Form_Load()
OldProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
End sub
Private Sub form_unload(Cancel As Integer)
'finish subclassing
retval = SetWindowLong(Me.hwnd, GWL_WNDPROC, OldAdress)
End sub
anybody has an idea ?
-
Code:
Private Sub Form_Load()
StartSubclassing Me.hWnd
End Sub
Private Sub Form_Unload(Cancel As Integer)
StopSubclassing
End Sub
'Module
Option Explicit
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal ndx As Long, ByVal newValue As Long) As Long
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
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long)
Const GWL_WNDPROC = -4
Public Const WM_PAINT = &HF
Public Const WM_SIZING = &H214
' --------------------------------------------
Dim saveHWnd As Long ' The handle of the subclassed window.
Dim oldProcAddr As Long ' The address of the original window procedure
Sub StartSubclassing(ByVal hWnd As Long)
saveHWnd = hWnd
oldProcAddr = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc)
End Sub
Sub StopSubclassing()
SetWindowLong saveHWnd, GWL_WNDPROC, oldProcAddr
End Sub
Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
WndProc = CallWindowProc(oldProcAddr, hWnd, uMsg, wParam, lParam)
Select Case uMsg
Case WM_SIZING
PostMessage hWnd, WM_PAINT, 0
Msgbox("Resizing")
End Select
End Function
Two points:
1) PostMessage only supports 3 arguments (not four)
2) WM_SIZE seems not to work properly, so I used WM_SIZING
It works on my computer, and I hope it works on yours.
I hope this helps,
Bye,
Me and my imaginary friend Bob
-
IF you want to stop it from making the form too small why even bother using Subclassing? Wouldn't it be easier:
Code:
Private Sub Form_Resize()
If Form1.Height < 10000 Then
Form1.Height = 10000
End If
If Form1.Width < 10000 Then
Form1.Width = 10000
End If
End Sub
-
If you catch the form_resize event, it looks ugly. First the window is being resized, then you get the resize event. With subclassing, you can catch it *before* the window is being resized, and that looks better.
This is (more or less) the code I usually use, and it works pretty fine...
code module:
Code:
Option Explicit
Private Const MY_PROPERTY_ORI_WINDOW_PROC = "_MY_WINDOWPROC_WNDPROC_"
Private Const MY_PROPERTY_ORI_WIDTH = "_MY_WINDOWPROC_WIDTH_"
Private Const MY_PROPERTY_ORI_HEIGHT = "_MY_WINDOWPROC_HEIGHT_"
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
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
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Sub CopyMemoryToMinMaxInfo Lib "KERNEL32" Alias "RtlMoveMemory" (hpvDest As MINMAXINFO, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Sub CopyMemoryFromMinMaxInfo Lib "KERNEL32" Alias "RtlMoveMemory" (ByVal hpvDest As Long, hpvSource As MINMAXINFO, ByVal cbCopy As Long)
Private Const GWL_WNDPROC = -4
Private Const WM_GETMINMAXINFO = &H24
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 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
Public Sub Hook(hWnd As Long, MinWidth As Integer, MinHeight As Integer)
' check if hWnd is a window
If Not MyIsWindow(hWnd) Then
Err.Raise vbObjectError + 505, "modSubclass::Hook", "hWnd is not a valid window handle"
Exit Sub
End If
' replace original windowproc with ours and save it...
l = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
Call SetProp(hWnd, MY_PROPERTY_ORI_WINDOW_PROC, l)
' save minwidth and minheight
Call SetProp(hWnd, MY_PROPERTY_ORI_WIDTH, MinWidth)
Call SetProp(hWnd, MY_PROPERTY_ORI_HEIGHT, MinHeight)
End Sub
Public Sub Unhook(hWnd As Long)
' check again
If Not MyIsWindow(hWnd) Then Exit Sub
' get original windowproc and set it back
l = GetProp(hWnd, MY_PROPERTY_ORI_WINDOW_PROC)
Call SetWindowLong(hWnd, GWL_WNDPROC, l)
' remove properties
Call RemoveProp(hWnd, MY_PROPERTY_ORI_WINDOW_PROC)
Call RemoveProp(hWnd, MY_PROPERTY_ORI_WIDTH)
Call RemoveProp(hWnd, MY_PROPERTY_ORI_HEIGHT)
End Sub
Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' only our message
If uMsg = WM_GETMINMAXINFO Then
Dim MinMax As MINMAXINFO
Static Width As Integer, Height As Integer
' read out the minwidth and minheight
Width = GetProp(hWnd, MY_PROPERTY_ORI_WIDTH)
Height = GetProp(hWnd, MY_PROPERTY_ORI_HEIGHT)
' change it to pixels
Width = Width / Screen.TwipsPerPixelX
Height = Height / Screen.TwipsPerPixelY
' lParam is a pointer to a minmaxinfo structure, copy it so we can modify it
CopyMemoryToMinMaxInfo MinMax, lParam, Len(MinMax)
' set values
MinMax.ptMinTrackSize.x = Width
MinMax.ptMinTrackSize.y = Height
' copy it back
CopyMemoryFromMinMaxInfo lParam, MinMax, Len(MinMax)
' tell windooz we handled this message
WindowProc = 1
Else
' get the original window proc and call it, let windooz handle the msg's we don't want
l = GetProp(hWnd, MY_PROPERTY_ORI_WINDOW_PROC)
WindowProc = CallWindowProc(l, hWnd, uMsg, wParam, lParam)
End If
End Function
Put this is a class (if you use it in a dll)
Code:
Public Sub Subclass(ByVal hWnd As Long, MinWidth As Integer, MinHeight As Integer)
If hWnd = 0 Then
Err.Raise 5556, , "hWnd is not valid!! Use Me.hWnd"
Exit Sub
End If
Call Hook(hWnd, MinWidth, MinHeight)
End Sub
' unload
Public Sub UnSubclass(ByVal hWnd As Long)
Call Unhook(hWnd)
End Sub
Have fun.. and watch out for crashes... always save your work before running (but that's not a bad thing to do anyway.... subclass or not).
has been tested with VB6, but it's code I used also in VB5 so it should work.
