Private Sub UserForm_Activate()
samesizeApplication Me
End Sub
Sub samesizeApplication(Usf As Object)
Dim ctl As Control, ratioW#, ratioH#, Cw, tbCw, I&
With Application: ratioW = .UsableWidth / Usf.Width: ratioH = .Height / Usf.Height: End With
Usf.Move 0, 0, Usf.Width * ratioW, Usf.Height * ratioH
For Each ctl In Usf.Controls
ctl.Move ctl.Left * ratioW, ctl.Top * ratioH, ctl.Width * ratioW, ctl.Height * ratioH
On Error Resume Next
ctl.Font.Size = Round(ctl.Font.Size * Application.Min(ratioH, ratioW))
On Error GoTo 0
If TypeName(ctl) = "ListBox" Or TypeOf ctl Is ListBox Then
If ctl.ColumnWidths <> "" Then
tbCw = Split(Replace(ctl.ColumnWidths, " pt", ""), ";")
For I = LBound(tbCw) To UBound(tbCw): tbCw(I) = Val(tbCw(I)) * ratioW: Next
ctl.ColumnWidths = Join(tbCw, ";")
End If
End If
Next
End Sub