subclassing resize event

[skullb]

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 ?

[V(ery) Basic]

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

[QWERTY]

IF you want to stop it from making the form too small why even bother using Subclassing? Wouldn't it be easier:

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

[Crazy D]

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:

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)

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.