VB根据窗体自动调整窗体内控件大小注：实用，可以直接引用

miaozk2006

于 2010-12-19 23:58:17 发布

882

本文链接：https://blog.csdn.net/miaozk2006/article/details/82416248

版权

代码如下：

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

On Error GoTo 0

End Sub

摘自：网络整理