Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hwnd As Long) As Long
Dim lpara As Long
Private Const CB_SETITEMHEIGHT = &H153
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Reset As Boolean
' if True, also fonts are resized
'Public ResizeFont As Boolean
' if True, form's height/width ratio is preserved
Public KeepRatio As Boolean
Private Type TControlInfo
ctrl As Control
Left As Single
Top As Single
Width As Single
Height As Single
FontSize As Single
End Type
' this array holds the original position
' and size of all controls on parent form
Dim Controls() As TControlInfo
' a reference to the parent form
Private WithEvents ParentForm As Form
' parent form's size at load time
Private ParentWidth As Single
Private ParentHeight As Single
' ratio of original height/width
Private HeightWidthRatio As Single
'Default Property Values:
Const m_def_ResizeFont = 0
'Property Variables:
Dim m_ResizeFont As Boolean
Sub LockWindow(hwnd As Long)
LockWindowUpdate hwnd
End Sub
Sub UnlockWindow()
LockWindowUpdate 0
End Sub
Private Sub ParentForm_Activate()
On Error Resume Next
ParentForm.Left = GetSetting(App.EXEName, ParentForm.Name, "Left", ParentForm.Left)
ParentForm.Top = GetSetting(App.EXEName, ParentForm.Name, "Top", ParentForm.Top)
ParentForm.Height = GetSetting(App.EXEName, ParentForm.Name, "Height", ParentForm.Height)
ParentForm.Width = GetSetting(App.EXEName, ParentForm.Name, "Width", ParentForm.Width)
End Sub
Private Sub ParentForm_Load()
' the ParentWidth variable works as a flag
ParentWidth = 0
' save original ratio
HeightWidthRatio = ParentForm.Height / ParentForm.Width
End Sub
Private Sub ParentForm_Unload(Cancel As Integer)
If Not ParentForm.WindowState = vbMinimized Then
If ParentForm.Left > -1000 Then SaveSetting App.EXEName, ParentForm.Name, "Left", ParentForm.Left
If ParentForm.Top > -1000 Then SaveSetting App.EXEName, ParentForm.Name, "Top", ParentForm.Top
If ParentForm.Height > 1000 Then SaveSetting App.EXEName, ParentForm.Name, "Height", ParentForm.Height
If ParentForm.Width > 1000 Then SaveSetting App.EXEName, ParentForm.Name, "Width", ParentForm.Width
End If
On Error Resume Next
If Reset = True Then DeleteSetting (App.EXEName)
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_ResizeFont = PropBag.ReadProperty("ResizeFont", m_def_ResizeFont)
If Ambient.UserMode = False Then Exit Sub
' store a reference to the parent form and
' start receiving events
Set ParentForm = Parent
End Sub
Private Sub UserControl_Resize()
' refuse to resize
Image1.Move 0, 0
UserControl.Width = Image1.Width
UserControl.Height = Image1.Height
End Sub
' trap the parent form's Resize event
' this include the very first resize event
' that occurs soon after form's load
Private Sub ParentForm_Resize()
If ParentForm.WindowState = 1 Then Exit Sub
If ParentWidth = 0 Then
Rebuild
Else
Refresh
End If
End Sub
' save size and position of all controls on parent form
' you should manually invoke this method each time you add a new control
' to the form (through Load method of a control array)
Sub Rebuild()
' rebuild the internal table
Dim i As Integer, ctrl As Control
' this is necessary for controls that don't support
' all properties (e.g. Timer controls)
On Error Resume Next
If Ambient.UserMode = False Then Exit Sub
' save a reference to the parent form, and its initial size
Set ParentForm = UserControl.Parent
ParentWidth = ParentForm.ScaleWidth
ParentHeight = ParentForm.ScaleHeight
' read the position of all controls on the parent form
ReDim Controls(ParentForm.Controls.Count - 1) As TControlInfo
Dim Ctl As Control
On Error Resume Next
' Put the code here to resize the controls
For i = 0 To ParentForm.Controls.Count - 1
With Controls(i)
' Set .ctrl = ctrl
If ParentForm.Controls(i).Left < -1000 Then 'For controls on diferent tab
Debug.Print ParentForm.Controls(i).Name
.Left = ParentForm.Controls(i).Left + 75000
Else
.Left = ParentForm.Controls(i).Left
End If
.Top = ParentForm.Controls(i).Top
.Width = ParentForm.Controls(i).Width
.Height = ParentForm.Controls(i).Height
.FontSize = ParentForm.Controls(i).Font.Size
End With
Next
End Sub
' update size and position of controls on parent form
Sub Refresh()
Dim i As Integer, ctrl As Control
Dim widthFactor As Single, heightFactor As Single
Dim minFactor As Single
' inhibits recursive calls if KeepRatio = True
Static executing As Boolean
If executing Then Exit Sub
If Ambient.UserMode = False Then Exit Sub
If KeepRatio And ParentForm.WindowState = 0 Then
executing = True
' we must keep original ratio
ParentForm.Height = HeightWidthRatio * ParentForm.Width
executing = False
End If
' this is necessary for controls that don't support
' all properties (e.g. Timer controls)
On Error Resume Next
widthFactor = ParentForm.ScaleWidth / ParentWidth
heightFactor = ParentForm.ScaleHeight / ParentHeight
' take the lesser of the two
If widthFactor < heightFactor Then
minFactor = widthFactor
Else
minFactor = heightFactor
End If
Dim Ctl As Control
LockWindow (ParentForm.hwnd)
' this is a regular resize
For i = 0 To ParentForm.Controls.Count - 1
With Controls(i)
' the change of font must occur *before* the resizing
' to account for companion scrollbar of listbox
' and other similar controls
If ResizeFont And (TypeOf ParentForm.Controls(i) Is TDBGrid) = False Then
ParentForm.Controls(i).Font.Size = .FontSize * minFactor
End If
' move and resize the controls - we can't use a Move
' method because some controls do not support the change
' of all the four properties (e.g. Height with comboboxes)
If ParentForm.Controls(i).Left < -1000 Then
Debug.Print ParentForm.Controls(i).Name
ParentForm.Controls(i).Left = .Left * widthFactor
ParentForm.Controls(i).Left = ParentForm.Controls(i).Left - 75000
Else
ParentForm.Controls(i).Left = .Left * widthFactor
End If
ParentForm.Controls(i).Top = .Top * heightFactor
ParentForm.Controls(i).Width = .Width * widthFactor
If TypeOf ParentForm.Controls(i) Is ComboBox Then
lpara = ((.Height * heightFactor) \ Screen.TwipsPerPixelX) - 6
Call SendMessage(ParentForm.Controls(i).hwnd, CB_SETITEMHEIGHT, -1&, ByVal lpara)
Else
ParentForm.Controls(i).Height = .Height * heightFactor
End If
End With
Next
UnlockWindow
End Sub
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
' m_ResizeFont = m_def_ResizeFont
m_ResizeFont = m_def_ResizeFont
End Sub
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("ResizeFont", m_ResizeFont, m_def_ResizeFont)
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,1
Public Property Get ResizeFont() As Boolean
ResizeFont = m_ResizeFont
End Property
Public Property Let ResizeFont(ByVal New_ResizeFont As Boolean)
m_ResizeFont = New_ResizeFont
PropertyChanged "ResizeFont"
End Property