-
Feb 7th, 2018, 05:36 AM
#1
Thread Starter
Fanatic Member
Mininimum limit when resizing
Hi
how to allow the minimum limit of resizing of a form ?
-
Feb 7th, 2018, 05:41 AM
#2
Re: Mininimum limit when resizing
You could do it in the Resize event of the form, but that will cause strange effects.
Better to subclass the form and check for changes:
http://www.vbforums.com/showthread.p...07#post1263307
http://www.vb-helper.com/howto_restrict_form_size.html
-
Feb 7th, 2018, 06:16 AM
#3
Thread Starter
Fanatic Member
Re: Mininimum limit when resizing
Originally Posted by Arnoutdv
Very , very Good
But I have a doubt How can I do when I have many forms in the project , How can I to control
Code:
Const MIN_WIDTH = 200
Const MAX_WIDTH = 500
Const MIN_HEIGHT = 100
Const MAX_HEIGHT = 300
for each form
BTW - How I put this topic with Correct Answer ?
-
Feb 7th, 2018, 07:15 AM
#4
Re: Mininimum limit when resizing
-
Feb 7th, 2018, 07:25 AM
#5
Re: Mininimum limit when resizing
Hi,
here is one simple way of doing it.
make the Form the minimum size you want, and put a Label at the bottom right corner and set it visible=False
place this in the Form
Code:
'Here is stored the current size of the form
Public FormOldWidth As Long
Public FormOldHeight As Long
Private Sub Form_Load()
'Set the size of the form
'Set the minimal size of the form with the Label
'in the right bottom corner of the form
Me.Width = Me.Label1.Left + (Me.Width - Me.ScaleWidth)
Me.Height = Me.Label1.Top + (Me.Height - Me.ScaleHeight)
Me.Top = 0
Me.Left = 0
Me.FormOldHeight = Me.Height
Me.FormOldWidth = Me.Width
End Sub
'Auto resize
Private Sub Form_Resize()
If Not Me.WindowState = vbMinimized Then
'Does not let it be smaller that the minimum settings
'this also works if MDI form is on normal view
If Me.Height < Label1.Top + (Me.Height - Me.ScaleHeight) Or Me.Width < Me.Label1.Left + (Me.Width - Me.ScaleWidth) Then
Me.Height = Label1.Top + (Me.Height - Me.ScaleHeight)
Me.Width = Me.Label1.Left + (Me.Width - Me.ScaleWidth)
Exit Sub
End If
End If
End Sub
regards
Chris
to hunt a species to extinction is not logical !
since 2010 the number of Tigers are rising again in 2016 - 3900 were counted. with Baby Callas it's 3901, my wife and I had 2-3 months the privilege of raising a Baby Tiger.
-
Feb 7th, 2018, 09:17 AM
#6
Re: Mininimum limit when resizing
Yet another subclassing solution:
Code:
Option Explicit 'In Module1.bas
Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Sub PutMem8 Lib "msvbvm60.dll" (ByVal Addr As Long, ByVal NewValLo As Long, ByVal NewValHi As Long) '<-- Modified NewVal param from Currency to 2 Longs
Public Function Subclass(ByRef Form As VB.Form, Optional ByVal MinWidth As Integer = -1, _
Optional ByVal MinHeight As Integer = -1, _
Optional ByVal MaxWidth As Integer = -1, _
Optional ByVal MaxHeight As Integer = -1) As Boolean
Dim uIdSubclass As Long, dwRefData As Long
If MinWidth = -1 Then MinWidth = Form.Width \ Screen.TwipsPerPixelX
If MinHeight = -1 Then MinHeight = Form.Height \ Screen.TwipsPerPixelY
If MaxWidth = -1 Then MaxWidth = Screen.Width \ Screen.TwipsPerPixelX
If MaxHeight = -1 Then MaxHeight = Screen.Height \ Screen.TwipsPerPixelY
uIdSubclass = MinHeight * &H10000 Or MinWidth And &HFFFF&
dwRefData = MaxHeight * &H10000 Or MaxWidth And &HFFFF&
Subclass = SetWindowSubclass(Form.hWnd, AddressOf SubclassProc, uIdSubclass, dwRefData): Debug.Assert Subclass
End Function
Private Function SubclassProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, _
ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Const WM_GETMINMAXINFO = &H24&, WM_DESTROY = &H2&, SIGN_BIT = &H80000000
Select Case uMsg
Case WM_GETMINMAXINFO
PutMem8 (lParam Xor SIGN_BIT) + 24& Xor SIGN_BIT, uIdSubclass And &HFFFF&, ((uIdSubclass And &H7FFF0000) \ &H10000) Or ((uIdSubclass And &H80000000) = &H80000000 And &H8000&)
PutMem8 (lParam Xor SIGN_BIT) + 32& Xor SIGN_BIT, dwRefData And &HFFFF&, ((dwRefData And &H7FFF0000) \ &H10000) Or ((dwRefData And &H80000000) = &H80000000 And &H8000&)
Exit Function
Case WM_DESTROY
SubclassProc = RemoveWindowSubclass(hWnd, AddressOf Module1.SubclassProc, uIdSubclass): Debug.Assert SubclassProc
End Select
SubclassProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
End Function
Code:
Option Explicit 'In a Form
Private Sub Form_Load()
Const MIN_WIDTH = 200, MIN_HEIGHT = 100
Const MAX_WIDTH = 500, MAX_HEIGHT = 300
Subclass Me, MIN_WIDTH, MIN_HEIGHT, MAX_WIDTH, MAX_HEIGHT
End Sub
Private Sub Form_Resize()
Caption = Name & ": " & (Width \ Screen.TwipsPerPixelX) & " x " & (Height \ Screen.TwipsPerPixelY)
End Sub
Last edited by Victor Bravo VI; Feb 9th, 2018 at 08:52 AM.
Reason: Changed uIdSubclass/dwRefData \ &H10000 And &HFFFF& to more correct HiWord formula.
-
Feb 7th, 2018, 10:27 AM
#7
Re: Mininimum limit when resizing
Here's the subclassing solution I put together for MaxSize. I've never needed MinSize, but it'd be easy to work out from the following code.
Code for BAS module:
Code:
Option Explicit
'
Public gbAllowSubclassing As Boolean
'
Private Const WM_DESTROY As Long = &H2&
'
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function GetWindowSubclass Lib "comctl32.dll" Alias "#411" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, pdwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function NextSubclassProcOnChain Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'
Dim bSetWhenSubclassing_UsedByIdeStop As Boolean ' Never goes false once set by first subclassing, unless IDE Stop button is clicked.
'
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Source As Any, ByVal Bytes As Long)
'
'**************************************************************************************
' The following MODULE level stuff is specific to individual subclassing needs.
'**************************************************************************************
'
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
'
'**************************************************************************************
'**************************************************************************************
'**************************************************************************************
'
' Generic subclassing procedures (used in many of the specific subclassing).
'
'**************************************************************************************
'**************************************************************************************
'**************************************************************************************
Private Sub SubclassSomeWindow(hWnd As Long, AddressOf_ProcToHook As Long, Optional dwRefData As Long)
' This just always uses hWnd for uIdSubclass, as we never have a need to subclass the same window to the same proc.
' The uniqueness is pfnSubclass and uIdSubclass (second and third argument below).
'
' This can be called AFTER the initial subclassing to update dwRefData.
'
If Not gbAllowSubclassing Then Exit Sub
'
bSetWhenSubclassing_UsedByIdeStop = True
Call SetWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd, dwRefData)
End Sub
Private Function GetSubclassRefData(hWnd As Long, AddressOf_ProcToHook As Long) As Long
' This one is used only to fetch the optional dwRefData you may have specified when calling SubclassSomeWindow.
' Typically this would only be used by the hooked procedure, but it is available to anyone.
Call GetWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd, GetSubclassRefData)
End Function
Private Function IsSubclassed(hWnd As Long, AddressOf_ProcToHook As Long) As Boolean
' This just tells us we're already subclassed.
Dim dwRefData As Long
IsSubclassed = GetWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd, dwRefData) = 1&
End Function
Private Sub UnSubclassSomeWindow(hWnd As Long, AddressOf_ProcToHook As Long)
' Only needed if we specifically want to un-subclass before we're closing the form (or control),
' otherwise, it's automatically taken care of when the window closes.
'
' Be careful, some subclassing may require additional cleanup that's not done here.
Call RemoveWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd)
End Sub
Private Function ProcedureAddress(AddressOf_TheProc As Long)
' A private "helper" function for writing the AddressOf_... functions (see above notes).
ProcedureAddress = AddressOf_TheProc
End Function
Private Function DummyProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
' This could be used to just use comctl32.dll to store data for us in the dwRefData.
'
' Give control to other hooks, if they exist.
DummyProc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
End Function
Private Function IdeStopButtonClicked() As Boolean
' The following works because all variables are cleared when the STOP button is clicked,
' even though other code may still execute such as Windows calling some of the subclassing procedures below.
IdeStopButtonClicked = Not bSetWhenSubclassing_UsedByIdeStop
End Function
'**************************************************************************************
'**************************************************************************************
'**************************************************************************************
Public Sub SubclassFormMaxSize(frm As VB.Form, MaxWidth As Long, MaxHeight As Long)
' MUST be done in Form_Load event so Windows doesn't resize form on small monitors.
' Also, move (such as center) the form after calling so that WM_GETMINMAXINFO is fired.
' Can be called repeatedly to change MaxWidth and/or MaxHeight with no harm done.
SubclassSomeWindow frm.hWnd, AddressOf MaxSize_Proc, CLng(MaxHeight * &H10000 + MaxWidth)
End Sub
Private Function MaxSize_Proc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
If uMsg = WM_DESTROY Then
UnSubclassSomeWindow hWnd, AddressOf_MaxSize_Proc
MaxSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
Exit Function
End If
If IdeStopButtonClicked Then ' Protect the IDE. Don't execute any specific stuff if we're stopping. We may run into COM objects or other variables that no longer exist.
MaxSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
Exit Function
End If
'
Dim MaxWidth As Long
Dim MaxHeight As Long
Dim MMI As MINMAXINFO
Const WM_GETMINMAXINFO As Long = &H24&
'
Select Case uMsg
Case WM_GETMINMAXINFO
MaxWidth = dwRefData And &HFFFF&
MaxHeight = (dwRefData And &H7FFF0000) \ &H10000
'
CopyMemory MMI, ByVal lParam, LenB(MMI)
MMI.ptMaxTrackSize.X = MaxWidth
MMI.ptMaxTrackSize.Y = MaxHeight
CopyMemory ByVal lParam, MMI, LenB(MMI)
Exit Function ' If we process the message, we must return 0 and not let more hook code execute.
End Select
'
' Give control to other hooks, if they exist.
MaxSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
End Function
Private Function AddressOf_MaxSize_Proc() As Long
AddressOf_MaxSize_Proc = ProcedureAddress(AddressOf MaxSize_Proc)
End Function
Test code in Form1:
Code:
Option Explicit
Private Sub Form_Load()
gbAllowSubclassing = True
SubclassFormMaxSize Me, 300, 300
End Sub
Also, your Form1 should be smaller than the max to start with (or you should resize it in Form_Load).
I'm going to eat some breakfast, but I'll work it out for MinSize a bit later.
Enjoy,
Elroy
EDIT1: Also, you get all of my "generic" comctl32 subclassing stuff too. It's "near" IDE safe. Also, for development, you could check to see if you're in the IDE and not set that gbAllowSubclassing flag.
Last edited by Elroy; Feb 8th, 2018 at 03:40 PM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
-
Feb 7th, 2018, 11:25 AM
#8
Re: Mininimum limit when resizing
Here it is for MinSize. Also, just as an FYI, this thing is entirely independent per-form. In other words, you can call it for as many forms as you like with different dimensions per form.
The BAS piece:
Code:
Option Explicit
'
Public gbAllowSubclassing As Boolean
'
Private Const WM_DESTROY As Long = &H2&
'
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function GetWindowSubclass Lib "comctl32.dll" Alias "#411" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, pdwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function NextSubclassProcOnChain Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'
Dim bSetWhenSubclassing_UsedByIdeStop As Boolean ' Never goes false once set by first subclassing, unless IDE Stop button is clicked.
'
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Source As Any, ByVal Bytes As Long)
'
'**************************************************************************************
' The following MODULE level stuff is specific to individual subclassing needs.
'**************************************************************************************
'
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
'
'**************************************************************************************
'**************************************************************************************
'**************************************************************************************
'
' Generic subclassing procedures (used in many of the specific subclassing).
'
'**************************************************************************************
'**************************************************************************************
'**************************************************************************************
Private Sub SubclassSomeWindow(hWnd As Long, AddressOf_ProcToHook As Long, Optional dwRefData As Long)
' This just always uses hWnd for uIdSubclass, as we never have a need to subclass the same window to the same proc.
' The uniqueness is pfnSubclass and uIdSubclass (second and third argument below).
'
' This can be called AFTER the initial subclassing to update dwRefData.
'
If Not gbAllowSubclassing Then Exit Sub
'
bSetWhenSubclassing_UsedByIdeStop = True
Call SetWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd, dwRefData)
End Sub
Private Function GetSubclassRefData(hWnd As Long, AddressOf_ProcToHook As Long) As Long
' This one is used only to fetch the optional dwRefData you may have specified when calling SubclassSomeWindow.
' Typically this would only be used by the hooked procedure, but it is available to anyone.
Call GetWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd, GetSubclassRefData)
End Function
Private Function IsSubclassed(hWnd As Long, AddressOf_ProcToHook As Long) As Boolean
' This just tells us we're already subclassed.
Dim dwRefData As Long
IsSubclassed = GetWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd, dwRefData) = 1&
End Function
Private Sub UnSubclassSomeWindow(hWnd As Long, AddressOf_ProcToHook As Long)
' Only needed if we specifically want to un-subclass before we're closing the form (or control),
' otherwise, it's automatically taken care of when the window closes.
'
' Be careful, some subclassing may require additional cleanup that's not done here.
Call RemoveWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd)
End Sub
Private Function ProcedureAddress(AddressOf_TheProc As Long)
' A private "helper" function for writing the AddressOf_... functions (see above notes).
ProcedureAddress = AddressOf_TheProc
End Function
Private Function DummyProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
' This could be used to just use comctl32.dll to store data for us in the dwRefData.
'
' Give control to other hooks, if they exist.
DummyProc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
End Function
Private Function IdeStopButtonClicked() As Boolean
' The following works because all variables are cleared when the STOP button is clicked,
' even though other code may still execute such as Windows calling some of the subclassing procedures below.
IdeStopButtonClicked = Not bSetWhenSubclassing_UsedByIdeStop
End Function
'**************************************************************************************
'**************************************************************************************
'**************************************************************************************
Public Sub SubclassFormMinSize(frm As VB.Form, MinWidth As Long, MinHeight As Long)
' MUST be done in Form_Load event so Windows doesn't resize form on small monitors.
' Also, move (such as center) the form after calling so that WM_GETMINMAXINFO is fired.
' Can be called repeatedly to change MinWidth and/or MinHeight with no harm done.
SubclassSomeWindow frm.hWnd, AddressOf MinSize_Proc, CLng(MinHeight * &H10000 + MinWidth)
End Sub
Private Function MinSize_Proc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
If uMsg = WM_DESTROY Then
UnSubclassSomeWindow hWnd, AddressOf_MinSize_Proc
MinSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
Exit Function
End If
If IdeStopButtonClicked Then ' Protect the IDE. Don't execute any specific stuff if we're stopping. We may run into COM objects or other variables that no longer exist.
MinSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
Exit Function
End If
'
Dim MinWidth As Long
Dim MinHeight As Long
Dim MMI As MINMAXINFO
Const WM_GETMINMAXINFO As Long = &H24&
'
Select Case uMsg
Case WM_GETMINMAXINFO
MinWidth = dwRefData And &HFFFF&
MinHeight = (dwRefData And &H7FFF0000) \ &H10000
'
CopyMemory MMI, ByVal lParam, LenB(MMI)
MMI.ptMinTrackSize.X = MinWidth
MMI.ptMinTrackSize.Y = MinHeight
CopyMemory ByVal lParam, MMI, LenB(MMI)
Exit Function ' If we process the message, we must return 0 and not let more hook code execute.
End Select
'
' Give control to other hooks, if they exist.
MinSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
End Function
Private Function AddressOf_MinSize_Proc() As Long
AddressOf_MinSize_Proc = ProcedureAddress(AddressOf MinSize_Proc)
End Function
A test Form1 piece:
Code:
Option Explicit
Private Sub Form_Load()
gbAllowSubclassing = True
SubclassFormMinSize Me, 300, 300
End Sub
Also, it makes sense to me to put this all together into one subclassing procedure. I'll post that momentarily.
Enjoy,
Elroy
Last edited by Elroy; Feb 8th, 2018 at 03:42 PM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
-
Feb 7th, 2018, 11:50 AM
#9
Re: Mininimum limit when resizing
Here it is all put together, MinWidth, MinHeight, MaxWidth, MaxHeight, or any combination.
The BAS piece:
Code:
Option Explicit
'
Public gbAllowSubclassing As Boolean
'
Private Const WM_DESTROY As Long = &H2&
'
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function GetWindowSubclass Lib "comctl32.dll" Alias "#411" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, pdwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function NextSubclassProcOnChain Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'
Dim bSetWhenSubclassing_UsedByIdeStop As Boolean ' Never goes false once set by first subclassing, unless IDE Stop button is clicked.
'
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Source As Any, ByVal Bytes As Long)
'
'**************************************************************************************
' The following MODULE level stuff is specific to individual subclassing needs.
'**************************************************************************************
'
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
'
'**************************************************************************************
'**************************************************************************************
'**************************************************************************************
'
' Generic subclassing procedures (used in many of the specific subclassing).
'
'**************************************************************************************
'**************************************************************************************
'**************************************************************************************
Private Sub SubclassSomeWindow(hWnd As Long, AddressOf_ProcToHook As Long, Optional dwRefData As Long)
' This just always uses hWnd for uIdSubclass, as we never have a need to subclass the same window to the same proc.
' The uniqueness is pfnSubclass and uIdSubclass (second and third argument below).
'
' This can be called AFTER the initial subclassing to update dwRefData.
'
If Not gbAllowSubclassing Then Exit Sub
'
bSetWhenSubclassing_UsedByIdeStop = True
Call SetWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd, dwRefData)
End Sub
Private Sub SubclassSomeWindowToDummy(hWnd As Long, ID As Long, dwRefData As Long)
' This is used solely to store extra data. Be sure ID is different from hWnd.
'
If Not gbAllowSubclassing Then Exit Sub
'
bSetWhenSubclassing_UsedByIdeStop = True
Call SetWindowSubclass(hWnd, AddressOf DummyProc, ID, dwRefData)
End Sub
Private Function GetSubclassRefData(hWnd As Long, AddressOf_ProcToHook As Long) As Long
' This one is used only to fetch the optional dwRefData you may have specified when calling SubclassSomeWindow.
' Typically this would only be used by the hooked procedure, but it is available to anyone.
Call GetWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd, GetSubclassRefData)
End Function
Private Function GetSubclassRefDataDummy(hWnd As Long, ID As Long) As Long
Call GetWindowSubclass(hWnd, AddressOf DummyProc, ID, GetSubclassRefDataDummy)
End Function
Private Function IsSubclassed(hWnd As Long, AddressOf_ProcToHook As Long) As Boolean
' This just tells us we're already subclassed.
Dim dwRefData As Long
IsSubclassed = GetWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd, dwRefData) = 1&
End Function
Private Sub UnSubclassSomeWindow(hWnd As Long, AddressOf_ProcToHook As Long)
' Only needed if we specifically want to un-subclass before we're closing the form (or control),
' otherwise, it's automatically taken care of when the window closes.
'
' Be careful, some subclassing may require additional cleanup that's not done here.
Call RemoveWindowSubclass(hWnd, AddressOf_ProcToHook, hWnd)
End Sub
Private Sub UnSubclassSomeWindowFromDummy(hWnd As Long, ID As Long)
Call RemoveWindowSubclass(hWnd, AddressOf DummyProc, ID)
End Sub
Private Function ProcedureAddress(AddressOf_TheProc As Long)
' A private "helper" function for writing the AddressOf_... functions (see above notes).
ProcedureAddress = AddressOf_TheProc
End Function
Private Function DummyProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
' This could be used to just use comctl32.dll to store data for us in the dwRefData.
'
' Give control to other hooks, if they exist.
DummyProc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
End Function
Private Function IdeStopButtonClicked() As Boolean
' The following works because all variables are cleared when the STOP button is clicked,
' even though other code may still execute such as Windows calling some of the subclassing procedures below.
IdeStopButtonClicked = Not bSetWhenSubclassing_UsedByIdeStop
End Function
'**************************************************************************************
'**************************************************************************************
'**************************************************************************************
Public Sub SubclassFormMinMaxSize(frm As VB.Form, Optional ByVal MinWidth As Long, Optional ByVal MinHeight As Long, Optional ByVal MaxWidth As Long, Optional ByVal MaxHeight As Long)
' MUST be done in Form_Load event so Windows doesn't resize form on small monitors.
' Also, move (such as center) the form after calling so that WM_GETMINMAXINFO is fired.
' Can be called repeatedly to change MinWidth, MinHeight, MaxWidth, and MaxHeight with no harm done.
' Although, all must be supplied that you wish to maintain.
'
' Not supplying an argument (i.e., leaving it zero) will cause it to be ignored.
'
' Some validation before subclassing.
If MinWidth > MaxWidth And MaxWidth <> 0 Then MaxWidth = MinWidth
If MinHeight > MaxHeight And MaxHeight <> 0 Then MaxHeight = MinHeight
'
SubclassSomeWindow frm.hWnd, AddressOf MinMaxSize_Proc, CLng(MinHeight * &H10000 + MinWidth)
SubclassSomeWindowToDummy frm.hWnd, frm.hWnd + 1, CLng(MaxHeight * &H10000 + MaxWidth)
End Sub
Private Function MinMaxSize_Proc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
If uMsg = WM_DESTROY Then
UnSubclassSomeWindowFromDummy hWnd, hWnd + 1
UnSubclassSomeWindow hWnd, AddressOf_MinMaxSize_Proc
MinMaxSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
Exit Function
End If
If IdeStopButtonClicked Then ' Protect the IDE. Don't execute any specific stuff if we're stopping. We may run into COM objects or other variables that no longer exist.
MinMaxSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
Exit Function
End If
'
Dim MinWidth As Long
Dim MinHeight As Long
Dim MaxWidth As Long
Dim MaxHeight As Long
Dim MMI As MINMAXINFO
Const WM_GETMINMAXINFO As Long = &H24&
'
Select Case uMsg
Case WM_GETMINMAXINFO
MinWidth = dwRefData And &HFFFF&
MinHeight = (dwRefData And &H7FFF0000) \ &H10000
dwRefData = GetSubclassRefDataDummy(hWnd, hWnd + 1)
MaxWidth = dwRefData And &HFFFF&
MaxHeight = (dwRefData And &H7FFF0000) \ &H10000
'
CopyMemory MMI, ByVal lParam, LenB(MMI)
If MinWidth <> 0 Then MMI.ptMinTrackSize.X = MinWidth
If MinHeight <> 0 Then MMI.ptMinTrackSize.Y = MinHeight
If MaxWidth <> 0 Then MMI.ptMaxTrackSize.X = MaxWidth
If MaxHeight <> 0 Then MMI.ptMaxTrackSize.Y = MaxHeight
CopyMemory ByVal lParam, MMI, LenB(MMI)
Exit Function ' If we process the message, we must return 0 and not let more hook code execute.
End Select
'
' Give control to other hooks, if they exist.
MinMaxSize_Proc = NextSubclassProcOnChain(hWnd, uMsg, wParam, lParam)
End Function
Private Function AddressOf_MinMaxSize_Proc() As Long
AddressOf_MinMaxSize_Proc = ProcedureAddress(AddressOf MinMaxSize_Proc)
End Function
A piece for Form1 testing:
Code:
Option Explicit
Private Sub Form_Load()
gbAllowSubclassing = True
SubclassFormMinMaxSize Me, 300, 300, 400, 0
End Sub
Enjoy,
Elroy
Last edited by Elroy; Feb 8th, 2018 at 03:43 PM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Tags for this Thread
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|