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
没有相关教程
注：本站部分文章源于互联网，版权归原作者所有！如有侵权，请原作者与本站联系，本站将立即删除！ 本站文章除特别注明外均可转载，但需注明出处！ [MinTao学以致用网] 
