合金装备5幻痛45:VB如何使控件位置和大小自动适应窗体变化的三种不同模式

VB如何使控件位置和大小自动适应窗体变化的三种不同模式

   有更好方法可以在交流。代码是无需更改的。

第一种。就是最实用的，就是所有控件的width和height按比例随窗体变化，位置也是当然是按比例哦。控件的字体不变。如下复制到代码：

    '改比例，字体不该。最实用


Option Explicit
Private FormOldWidth     As Long     '保存窗体的原始宽度
Private FormOldHeight     As Long     '保存窗体的原始高度
Private Sub Form_Load()
       Call ResizeInit(Me)     '在程序装入时必须加入
End Sub
  
 Private Sub Form_Resize()

       Call ResizeForm(Me)     '确保窗体改变时控件随之改变
End Sub



'在调用ResizeForm前先调用本函数
Public Sub ResizeInit(FormName As Form)
      Dim Obj     As Control
      FormOldWidth = FormName.ScaleWidth
      FormOldHeight = FormName.ScaleHeight
      On Error Resume Next
      For Each Obj In FormName
          Obj.Tag = Obj.Left & "   " & Obj.Top & "   " & Obj.Width & "   " & Obj.Height & "   "
      Next Obj
      On Error GoTo 0
End Sub
  
 '按比例改变表单内各元件的大小，在调用ReSizeForm前先调用ReSizeInit函数
Public Sub ResizeForm(FormName As Form)
      Dim Pos(4)     As Double
      Dim i     As Long, TempPos       As Long, StartPos       As Long
      Dim Obj     As Control
      Dim ScaleX     As Double, ScaleY       As Double
      ScaleX = FormName.ScaleWidth / FormOldWidth           '保存窗体宽度缩放比例
      ScaleY = FormName.ScaleHeight / FormOldHeight           '保存窗体高度缩放比例
      On Error Resume Next
      For Each Obj In FormName
          StartPos = 1
          For i = 0 To 4
          '读取控件的原始位置与大小
              TempPos = InStr(StartPos, Obj.Tag, "   ", vbTextCompare)
              If TempPos > 0 Then
                  Pos(i) = Mid(Obj.Tag, StartPos, TempPos - StartPos)
                  StartPos = TempPos + 1
              Else
                  Pos(i) = 0
              End If
        '根据控件的原始位置及窗体改变大小的比例对控件重新定位与改变大小
              Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, Pos(2) * ScaleX, Pos(3) * ScaleY
          Next i
      Next Obj
      On Error GoTo 0
End Sub

第二种，只位置就是控件的left和top随着变。其他都不变。如果变化大了不好看。如下复制：

Option Explicit
    Private ObjOldWidth As Long '保存窗体的原始宽度
    Private ObjOldHeight As Long '保存窗体的原始高度
    Private ObjOldFont As Single '保存窗体的原始字体比

Private Sub Form_Resize()
     '确保窗体改变时控件随之改变
     Call ResizeForm(Me)
    End Sub
    Private Sub Form_Load()
     '在程序装入时必须加入
     Call ResizeInit(Me)
    End Sub

'    '在调用ResizeForm前先调用本函数
    Public Sub ResizeInit(FormName As Form)
     Dim Obj As Control

     ObjOldWidth = FormName.ScaleWidth
     ObjOldHeight = FormName.ScaleHeight
     ObjOldFont = FormName.Font.Size / ObjOldHeight
     On Error Resume Next
     For Each Obj In FormName
     Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " "
     Next Obj

     On Error GoTo 0
    End Sub
    '按比例改变表单内各元件的大小，
    '在调用ReSizeForm前先调用ReSizeInit函数
    Public Sub ResizeForm(FormName As Form)
     Dim Pos(4) As Double
     Dim i As Long, TempPos As Long, StartPos As Long
     Dim Obj As Control
     Dim ScaleX As Double, ScaleY As Double

     ScaleX = FormName.ScaleWidth / ObjOldWidth
     '保存窗体宽度缩放比例
     ScaleY = FormName.ScaleHeight / ObjOldHeight
     '保存窗体高度缩放比例
     On Error Resume Next

     For Each Obj In FormName
     StartPos = 1
     For i = 0 To 4
     '读取控件的原始位置与大小
     TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare)
     If TempPos > 0 Then
     Pos(i) = Mid(Obj.Tag, StartPos, TempPos - StartPos)
     StartPos = TempPos + 1
     Else
     Pos(i) = 0
     End If

     '根据控件的原始位置及窗体改变大
     '小的比例对控件重新定位与改变大小
     Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY
  
     Next i

     Next Obj

    End Sub

第三种，就是所有的都按比例。包括大小。字体，位置，就像放大镜的感觉。复制如下：

Option Explicit
    Private ObjOldWidth As Long '保存窗体的原始宽度
    Private ObjOldHeight As Long '保存窗体的原始高度
    Private ObjOldFont As Single '保存窗体的原始字体比
'窗体部分
Private Sub Form_Resize()
     '确保窗体改变时控件随之改变
     Call ResizeForm(Me)
    End Sub
    Private Sub Form_Load()
     '在程序装入时必须加入
     Call ResizeInit(Me)
    End Sub

'    '在调用ResizeForm前先调用本函数
    Public Sub ResizeInit(FormName As Form)
     Dim Obj As Control

     ObjOldWidth = FormName.ScaleWidth
     ObjOldHeight = FormName.ScaleHeight
     ObjOldFont = FormName.Font.Size / ObjOldHeight
     On Error Resume Next
     For Each Obj In FormName
     Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " "
     Next Obj

     On Error GoTo 0
    End Sub
    '按比例改变表单内各元件的大小，
    '在调用ReSizeForm前先调用ReSizeInit函数
    Public Sub ResizeForm(FormName As Form)
     Dim Pos(4) As Double
     Dim i As Long, TempPos As Long, StartPos As Long
     Dim Obj As Control
     Dim ScaleX As Double, ScaleY As Double

     ScaleX = FormName.ScaleWidth / ObjOldWidth
     '保存窗体宽度缩放比例
     ScaleY = FormName.ScaleHeight / ObjOldHeight
     '保存窗体高度缩放比例
     On Error Resume Next

     For Each Obj In FormName
     StartPos = 1
     For i = 0 To 4
     '读取控件的原始位置与大小
     TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare)
     If TempPos > 0 Then
     Pos(i) = Mid(Obj.Tag, StartPos, TempPos - StartPos)
     StartPos = TempPos + 1
     Else
     Pos(i) = 0
     End If

     '根据控件的原始位置及窗体改变大
     '小的比例对控件重新定位与改变大小
     Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, Pos(2) * ScaleX, Pos(3) * ScaleY
     Obj.Font.Size = ObjOldFont * FormName.ScaleHeight
     Next i

     Next Obj

    End Sub