解决窗体中的控件自动随窗体大小变化的控件－－源码

Question

'这是把代码直接放在窗体中没有问题
Option Explicit
Private Type RECT
        Left As Long
        Top As Long
        Width As Long
        Height As Long
End Type
Private crlMsg() As RECT
Private sngWidth As Single
Private sngHeight As Single
Private sngScaleX As Single
Private sngScaleY As Single
Private intNum As IntegerPrivate Sub Form_Load()
    '打开错误处理陷阱
   On Error GoTo ErrGoto
   '----------------------------------------------------
   '代码正文
  
    Dim i As Integer
     intNum = Me.Controls.Count
     ReDim Preserve crlMsg(intNum - 1) As RECT
     
     For i = 0 To intNum - 1
        crlMsg(i).Left = Me.Controls(i).Left
        crlMsg(i).Top = Me.Controls(i).Top
        crlMsg(i).Width = Me.Controls(i).Width
        crlMsg(i).Height = Me.Controls(i).Height
     Next
     
     sngWidth = Me.Width
     sngHeight = Me.Height
     
     sngScaleX = 1
     sngScaleY = 1
   '----------------------------------------------------
   Exit Sub
   '-----------------------------
ErrGoto:
  Resume NextEnd SubPrivate Sub Form_Resize()
   '打开错误处理陷阱
   On Error GoTo ErrGoto
   '----------------------------------------------------
   '代码正文
  Static oldX As Single
  Static oldY As Single
  Dim i As Integer
  
  sngScaleX = Me.Width * 1# / sngWidth
  sngScaleY = Me.Height * 1# / sngHeight
  
  If Abs(sngScaleX - oldX) > 0.01 Or Abs(sngScaleY - oldY) > 0.01 Then
    For i = 0 To intNum - 1
        Me.Controls(i).Left = crlMsg(i).Left * sngScaleX
        Me.Controls(i).Top = crlMsg(i).Top * sngScaleY
        Me.Controls(i).Width = crlMsg(i).Width * sngScaleX
        Me.Controls(i).Height = crlMsg(i).Height * sngScaleY
     Next
  End If
  
  oldX = sngScaleX
  oldY = sngScaleY
  
  '----------------------------------------------------
   Exit Sub
   '-----------------------------
ErrGoto:
  Resume NextEnd Sub可放在控件中....代码如下

Answer 1

Option Explicit
Private Type RECT
        Left As Long
        Top As Long
        Width As Long
        Height As Long
End Type
Private crlMsg() As RECT
Private sngWidth As Single
Private sngHeight As Single
Private sngScaleX As Single
Private sngScaleY As Single
Private intNum As Integer
Private Sub UserControl_Resize()
   UserControl.Width = 480
   UserControl.Height = 480
End SubPrivate Sub tmrRun_Timer()
  Static oldX As Single
  Static oldY As Single
  Dim i As Integer
  sngScaleX = UserControl.Extender.Parent.Width * 1# / sngWidth
  sngScaleY = UserControl.Extender.Parent.Height * 1# / sngHeight
  
  If Abs(sngScaleX - oldX) > 0.01 Or Abs(sngScaleY - oldY) > 0.01 Then
    For i = 0 To intNum - 1
        UserControl.Extender.Parent.Controls(i).Left = crlMsg(i).Left * sngScaleX
        UserControl.Extender.Parent.Controls(i).Top = crlMsg(i).Top * sngScaleY
        UserControl.Extender.Parent.Controls(i).Width = crlMsg(i).Width * sngScaleX
        UserControl.Extender.Parent.Controls(i).Height = crlMsg(i).Height * sngScaleY
     Next
  End If
  
  oldX = sngScaleX
  oldY = sngScaleY
End SubPrivate Sub UserControl_ReadProperties(PropBag As PropertyBag)
   Dim i As Integer
   If Ambient.UserMode = False Then
     tmrRun.Enabled = False
   Else
     tmrRun.Enabled = True
     
     intNum = UserControl.Extender.Parent.Controls.Count     '这里仅一个，并且是自己本身，为什么？？？？
     ReDim Preserve crlMsg(intNum - 1) As RECT
     
     For i = 0 To intNum - 1
        crlMsg(i).Left = UserControl.Extender.Parent.Controls(i).Left
        crlMsg(i).Top = UserControl.Extender.Parent.Controls(i).Top
        crlMsg(i).Width = UserControl.Extender.Parent.Controls(i).Width
        crlMsg(i).Height = UserControl.Extender.Parent.Controls(i).Height
     Next
     
     sngWidth = UserControl.Extender.Parent.Width
     sngHeight = UserControl.Extender.Parent.Height
     
     sngScaleX = 1
     sngScaleY = 1
     
   End If
End Sub

Answer 2

在Form_Load中调用ResizeInit
在Form_Resize中调用ResizeForm
经过试验，绝对OK
'写成模块ModFormResize
public FormOldWidth as long
public FormOldHeight as longpublic Sub ResizeInit(FormName as form)   '记录窗体及各控件原始位置及尺寸
Dim Obj As ControlFormOldWidth = FormName.ScaleWidth
FormOldHeight = FormName.ScaleHeightOn Error Resume Next
For Each Obj In FormName
    Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " "
Next Obj
End Subpublic Sub ResizeForm(FormName as form)  '当窗体大小发生变化时，各控件尺寸及位置作相应变化
Dim Pos    '控件原先尺寸、位置
Dim I As Long  '计数器
Dim Obj As Control   '遍历窗体内控件
Dim ScaleX As Double, ScaleY As Double   '缩放比例ScaleX = Me.ScaleWidth / FormOldWidthScaleY = Me.ScaleHeight / FormOldHeightOn Error Resume NextFor Each Obj In Me
    Pos = Split(Obj.Tag, " ", , vbTextCompare)
    Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, Pos(2) * ScaleX, Pos(3) * ScaleY
Next Obj
End Sub

Answer 3

好象不要这么复杂吧
将以下代码放在要缩放的窗体中：
Dim a1, a2 as integerPrivate Sub Form_Load()
a1 = Me.Width
a2 = Me.Height
End SubPrivate Sub Form_Resize()
    Call AdjustForm(Me.Width / a1, Me.Height / a2, Me)'调用模块
    a1 = Me.Width
    a2 = Me.Height
End Sub
将以下过程放在模块中：
Public Sub AdjustForm(scaleX As Single, scaleY As Single, frm As Form)
    Dim s As Object
    On Error Resume Next
    For Each s In frm.Controls
        s.Left = s.Left * scaleX
        s.Top = s.Top * scaleY
        s.Width = s.Width * scaleX
        s.Height = s.Height * scaleY
    Next
End Sub

Answer 4

我就是用这个：在Form_Load中调用ResizeInit
在Form_Resize中调用ResizeForm'写成模块ModFormResize
public FormOldWidth as long
public FormOldHeight as longpublic Sub ResizeInit(FormName as form)   '记录窗体及各控件原始位置及尺寸
Dim Obj As ControlFormOldWidth = FormName.ScaleWidth
FormOldHeight = FormName.ScaleHeightOn Error Resume Next
For Each Obj In FormName
    Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " "
Next Obj
End Subpublic Sub ResizeForm(FormName as form)  '当窗体大小发生变化时，各控件尺寸及位置作相应变化
Dim Pos    '控件原先尺寸、位置
Dim I As Long  '计数器
Dim Obj As Control   '遍历窗体内控件
Dim ScaleX As Double, ScaleY As Double   '缩放比例ScaleX = Me.ScaleWidth / FormOldWidthScaleY = Me.ScaleHeight / FormOldHeightOn Error Resume NextFor Each Obj In Me
    Pos = Split(Obj.Tag, " ", , vbTextCompare)
    Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, Pos(2) * ScaleX, Pos(3) * ScaleY
Next Obj
End Sub