Resize所有控件

Option Explicit
' 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
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 UserControl_ReadProperties (PropBag As PropertyBag)
ResizeFont = PropBag.ReadProperty("ResizeFont", _
False)
KeepRatio = PropBag.ReadProperty("KeepRatio", _
False)
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_WriteProperties (PropBag As PropertyBag)
PropBag.WriteProperty "ResizeFont", ResizeFont, _
False
PropBag.WriteProperty "KeepRatio", KeepRatio, _
False
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 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
For i = 0 To ParentForm.Controls.Count ?1
Set ctrl = ParentForm.Controls(i)
With Controls(i)
Set .ctrl = ctrl
.Left = ctrl.Left
.Top = ctrl.Top
.Width = ctrl.Width
.Height = ctrl.Height
.FontSize = ctrl.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 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
' this is a regular resize
For i = 0 To UBound(Controls)
   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 Then
.ctrl.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
' (eg. Height with comboboxes)
.ctrl.Left = .Left * widthFactor
.ctrl.Top = .Top * heightFactor
.ctrl.Width = .Width * widthFactor
.ctrl.Height = .Height * heightFactor
   End With
Next
End Sub
  • 0
    点赞
  • 0
    收藏
  • 打赏
    打赏
  • 0
    评论

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
©️2022 CSDN 皮肤主题:大白 设计师:CSDN官方博客 返回首页
评论

打赏作者

shuwork

你的鼓励将是我创作的最大动力

¥2 ¥4 ¥6 ¥10 ¥20
输入1-500的整数
余额支付 (余额:-- )
扫码支付
扫码支付:¥2
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值