1 '***************************************************************************
   2 ''' // Resizable User Forms
   3 ''' // Based on code from Stephen Bullen
   4 ''' // http://www.oaltd.co.uk/
   5 ''' // Direct Link: http://www.oaltd.co.uk/Excel/Default.htm
   6 
   7 ''' // This version has been changed and extended supporting Minimize and Maximize Buttons plus
   8 ''' // allowing to set a minimum size of the user form.
   9 ''' // (c)digital-ecom GmbH 2009
  10 ''' // http://www.digital-ecom.de
  11 ''' // Note: All original comments were used where possible. Our comments are introduced by ''' // always.
  12 
  13 'This class makes a userform resizable and handles the resizing of all the controls on the userform,
  14 'such that their physical dimensions (e.g. size and position) change as the form is resized.
  15 'Note that this is not a form 'magnifier', in that it does not alter font sizes.
  16 
  17 'To specify which control(s) to resize (and how), you set the control's .Tag property at design time to
  18 'indicate that the control's top, left, width and height should be adjusted as the form's size changes.
  19 '
  20 'Use the letters t, l, w and h in any order (or not at all) to state that the property should change as the form
  21 'is resized.  Follow the property by a decimal to indicate that the control should change by a percentage of the
  22 'form's change.
  23 '
  24 'For example:
  25 '  hw           Sets the control's height and width to change with the form (e.g. if there's a single list box on the form)
  26 '  tl               Sets the contol's top and left to change in line with the form (e.g. to keep it in the bottom-right corner)
  27 '  w0.5        Sets the control's width to change by 0.5 that of the form's width change
  28 '  w0.5l0.5   Sets the control's width and position to change by 0.5 that of the form's width change
  29 
  30 '***************************************************************************
  31 Option Explicit
  32 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  33 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  34 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  35 Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
  36 Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
  37 Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
  38 Private Const GWL_STYLE As Long = (-16)                     'The offset of a window's style
  39 Private Const WS_THICKFRAME As Long = &H40000       'Style to add a sizable frame
  40 Private Const SW_SHOW As Long = 5
  41 Dim moForm As Object
  42 Attribute moForm.VB_VarHelpID = -1
  43 Dim mdWidth As Double
  44 Dim mdHeight As Double
  45 
  46 'Property to set the userform to be resizable
  47 ''' // This Property is set when initializing the User Form (->dlgResizeDemo -> UserForm_Activate)
  48 Public Property Set Form(oNew As Object)
  49 Dim hWndForm As Long, iStyle As Long
  50     'Remember the form for later
  51     Set moForm = oNew
  52     'Get the userform's window handle
  53     If Val(Application.Version) < 9 Then
  54         hWndForm = FindWindow("ThunderXFrame", moForm.Caption) 'XL 97
  55     Else
  56         hWndForm = FindWindow("ThunderDFrame", moForm.Caption) 'XL > 2000
  57     End If
  58     'Make the form resizable
  59     iStyle = GetWindowLong(hWndForm, GWL_STYLE)
  60     iStyle = iStyle Or WS_THICKFRAME
  61     SetWindowLong hWndForm, GWL_STYLE, iStyle
  62     'Show the window with the changes
  63     ShowWindow hWndForm, SW_SHOW
  64     DrawMenuBar hWndForm
  65     SetFocus hWndForm
  66     'Remember the current size for later
  67     mdWidth = moForm.Width
  68     mdHeight = moForm.Height
  69 End Property
  70 
  71 'Handle the form's resize event, by resizing and repositioning controls
  72 ''' // This sub is called when drawing the menu bar (DrawMenuBar hWndForm) and triggering the Forms Resize event (User Form (->dlgResizeDemo -> UserForm_Resize)
  73 Public Sub FormResize(minWidth As Double, minHeight As Double)
  74 Dim dWidthAdj As Double, dHeightAdj As Double
  75 Dim sTag As String
  76 Dim oCtl As MSForms.Control
  77 Dim Min_Size As Boolean
  78 
  79     ''' // If Dlg is loaded 1st time those values are not set - set to min size of Dlg then
  80     If mdWidth = 0 Then mdWidth = moForm.Width
  81     If mdHeight = 0 Then mdHeight = moForm.Height
  82 
  83     ''' // moForm.Width and moForm.Height  are set by API when resizing the Dlg - if smaller than min Dlg size set to min size
  84     If moForm.Width < mdWidth And moForm.Width <= minWidth Then
  85         moForm.Width = minWidth
  86     End If
  87 
  88     If moForm.Height < mdHeight And moForm.Height <= minHeight Then
  89         moForm.Height = minHeight
  90     End If
  91 
  92     ''' // Calculate the adjust value - by current DLG size minus previous size
  93     dWidthAdj = moForm.Width - mdWidth
  94     dHeightAdj = moForm.Height - mdHeight
  95 
  96     'Loop through the controls on the form, changing their size and/or position
  97     For Each oCtl In moForm.Controls
  98         With oCtl
  99             sTag = UCase(.Tag)
 100             If InStr(1, sTag, "L", vbBinaryCompare) Then .Left = .Left + dWidthAdj * ResizeFactor(sTag, "L")
 101             If InStr(1, sTag, "T", vbBinaryCompare) Then .Top = .Top + dHeightAdj * ResizeFactor(sTag, "T")
 102             If InStr(1, sTag, "W", vbBinaryCompare) Then .Width = .Width + dWidthAdj * ResizeFactor(sTag, "W")
 103             If InStr(1, sTag, "H", vbBinaryCompare) Then .Height = .Height + dHeightAdj * ResizeFactor(sTag, "H")
 104         End With
 105     Next
 106 
 107     If moForm.Width < minWidth Then
 108         mdWidth = minWidth
 109     Else
 110         mdWidth = moForm.Width
 111     End If
 112 
 113     If moForm.Height < minHeight Then
 114         mdHeight = minHeight
 115     Else
 116         mdHeight = moForm.Height
 117     End If
 118 End Sub
 119 
 120 'Get the resize factor from the control's Tag property
 121 Private Function ResizeFactor(sTag As String, sChange As String)
 122 Dim i As Integer, d As Double
 123     'Find the position of the required change designator (L, T, W or H)
 124     i = InStr(1, sTag, sChange, vbBinaryCompare)
 125 
 126     If i > 0 Then
 127         'Get the value of any numbers following the designator
 128         d = Val(Mid$(sTag, i + 1))
 129         'If none there, change by 100%
 130         If d = 0 Then d = 1
 131     End If
 132     ResizeFactor = d
 133 End Function