VB窗体初始最大化和改变窗体大小自动缩放控件及字体

1、模块代码：

'标准模块声明写入(自定义类型)
Type cp
    wp As Single
    hp As Single
    tp As Single
    lp As Single
    fp As Single
End Type
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'屏幕尺寸
Private Declare Function GetSystemMetrics32 Lib "user32" _
Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Public ap() As cp  '定义窗体数组
'屏幕宽
Function ScreenWidth() As Long
    ScreenWidth = GetSystemMetrics32(0) * 15
End Function
'屏幕高，去除底部状态栏高度
Function ScreenHeight() As Long
    ScreenHeight = (GetSystemMetrics32(1) - 40) * 15
End Function
Public Function MyGetWinDirectory() As String
    Dim sBuffer As String
    Dim lSize As Long
    sBuffer = String(255, 0)
    lSize = GetWindowsDirectory(sBuffer, Len(sBuffer))
    sBuffer = Left(sBuffer, lSize)
    sBuffer = sBuffer + "\"
    MyGetWinDirectory = sBuffer
End Function
'定义窗体过程
Public Sub GetControlsSize(ByVal fm As Form)
    On Error GoTo uerror   '跳过无width属性控件
    With fm
        For i = 0 To .Controls.Count - 1
            ap(i).wp = .Controls(i).Width / .ScaleWidth
            ap(i).hp = .Controls(i).Height / .ScaleHeight
            ap(i).lp = .Controls(i).Left / .ScaleWidth
            ap(i).tp = .Controls(i).Top / .ScaleHeight
            ap(i).fp = .Controls(i).Font.Size / (.Controls(i).Width * .Controls(i).Height)
        Next i
    End With
    Exit Sub
uerror:
    Resume Next
End Sub

2、窗体代码

'加载窗体
Private Sub Form_Load()
    '获取每个控件大小比例
    On Error GoTo uerror
    ReDim ap(0 To Me.Controls.Count - 1)
uerror:
    Resume Next
    GetControlsSize Me
    '窗口最大化
    Me.Left = 0
    Me.Top = 0
    Me.Width = ScreenWidth
    Me.Height = ScreenHeight
End Sub
'窗体尺寸改变时
Private Sub Form_Resize()
    Dim i As Integer
    On Error GoTo uerror
    For i = 0 To Controls.Count - 1
        Controls(i).Move ap(i).lp * Me.ScaleWidth, ap(i).tp * Me.ScaleHeight, ap(i).wp * Me.ScaleWidth, ap(i).hp * Me.ScaleHeight
        If Not Me.Controls(i).Name Like "ListView*" Then
            Controls(i).Font.Size = ap(i).fp * (Controls(i).Width * Controls(i).Height)
        End If
    Next i
    Exit Sub
uerror:
    Resume Next
End Sub

转自CSDN