dcsimg
Results 1 to 9 of 9
  1. #1

    Thread Starter
    Fanatic Member mutley's Avatar
    Join Date
    Apr 2000
    Location
    Sao Paulo - Brazil
    Posts
    681

    Arrow Mininimum limit when resizing

    Hi

    how to allow the minimum limit of resizing of a form ?

  2. #2
    PowerPoster
    Join Date
    Oct 2013
    Posts
    3,099

    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

  3. #3

    Thread Starter
    Fanatic Member mutley's Avatar
    Join Date
    Apr 2000
    Location
    Sao Paulo - Brazil
    Posts
    681

    Re: Mininimum limit when resizing

    Quote Originally Posted by Arnoutdv View Post
    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
    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 ?

  4. #4
    PowerPoster
    Join Date
    Oct 2013
    Posts
    3,099

    Re: Mininimum limit when resizing

    Check the subclass class by the Trick:
    http://www.vbforums.com/showthread.p...ws-and-classes

  5. #5
    Frenzied Member ChrisE's Avatar
    Join Date
    Jun 2017
    Location
    Frankfurt
    Posts
    1,063

    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.

  6. #6
    Lively Member
    Join Date
    Aug 2017
    Posts
    97

    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 07:52 AM. Reason: Changed uIdSubclass/dwRefData \ &H10000 And &HFFFF& to more correct HiWord formula.

  7. #7
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    4,197

    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 02: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. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. To all, peace and happiness.

  8. #8
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    4,197

    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 02: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. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. To all, peace and happiness.

  9. #9
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    4,197

    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 02: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. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. 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
  •  



Featured


Click Here to Expand Forum to Full Width


×
We have made updates to our Privacy Policy to reflect the implementation of the General Data Protection Regulation.