窗体控件根据分辨率自适应大小

Option Compare Database
‘loooooo
Type JLtype '记录控件的属性
Tn As String '控件名
T1 As Integer '控件上边距离
L1 As Integer '控件左边距离
W1 As Integer '控件宽度
H1 As Integer '控件高度
End Type


Type CTS '记录窗体的属性
Cn As String '窗体名
OLDW As Integer '窗体原始宽
OLDH As Integer '窗体原始高
TZzz() As JLtype '窗体控件的属性数组
i As Integer '记录窗体控件数组的上标
End Type

Public CC() As CTS '记录窗体的数组（注意窗体太多时可能占用内存）


Public Sub TZLoad(Frm As Form)
'--------------------------
On Error GoTo cuowu1
Dim Cw As Long '检查窗体的下标，系统第一次打开时很重要
Cw = UBound(CC)
'----------------------------
On Error GoTo cuowu


Dim N As String
Dim JJ As Integer
Dim PD As Boolean
'在数组中寻找窗体，找不到就增加一个
N = Frm.Name
For JJ = LBound(CC) To UBound(CC)
If CC(JJ).Cn = N Then
   PD = True
   Exit For
Else
  PD = False
End If
Next JJ

If PD = False Then
JJ = JJ + 1
ReDim Preserve CC(JJ)
End If


'重新给值，防止发生错误时关闭窗体后能重新加载
CC(JJ).Cn = N
CC(JJ).OLDH = Frm.InsideHeight
CC(JJ).OLDW = Frm.InsideWidth
CC(JJ).i = 0 '初开始化原来的数据

Dim obj As Control
Dim L As Integer

For Each obj In Frm
CC(JJ).i = CC(JJ).i + 1
L = CC(JJ).i
ReDim Preserve CC(JJ).TZzz(L)
CC(JJ).TZzz(L).Tn = obj.Name
CC(JJ).TZzz(L).T1 = obj.Top
CC(JJ).TZzz(L).L1 = obj.Left
CC(JJ).TZzz(L).W1 = obj.Width
CC(JJ).TZzz(L).H1 = obj.Height
Next obj


Exit Sub

cuowu1:
ReDim CC(1)
Resume Next

cuowu:
MsgBox Err.Description
Exit Sub

End Sub


Public Sub TZsize(Frmt As Form)
On Error GoTo cuowu

Dim N As String
Dim X As Double
Dim Y As Double
Dim j As Integer
Dim JJ As Integer

N = Frmt.Name

For JJ = LBound(CC) To UBound(CC)
If CC(JJ).Cn = N Then Exit For
Next JJ


Dim obj As Control

Y = Frmt.InsideHeight / CC(JJ).OLDH
X = Frmt.InsideWidth / CC(JJ).OLDW

Frmt.Section(acDetail).Height = Frmt.InsideHeight '主体很重要,否则要出错

For j = 1 To CC(JJ).i
Set obj = Frmt(CC(JJ).TZzz(j).Tn)
With obj
.Top = CC(JJ).TZzz(j).T1 * Y
.Left = CC(JJ).TZzz(j).L1 * X
.Width = CC(JJ).TZzz(j).W1 * X
.Height = CC(JJ).TZzz(j).H1 * Y
End With
Next j

Exit Sub

cuowu:
MsgBox Err.Description
Exit Sub

End Sub

'使用方法：
'窗体加载时：call TZload(me)
'调整大小时：call TZsize(me)