Access 控件自适应分辨率

来源:www.accessofe.com 点击数:5155 　 | 收藏 | 复制

时　间:2019-11-25 18:15:14
作　者:蒋东林 ID：72854 城市：重庆
摘　要:access 控件自适应 vba代码
原作者：loooooo
修改： auqaiss
正　文:

原作者：loooooo

修改： auqaiss

Option Compare Database
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)
'if obj.Name="
With obj
If Len(.name) < 16 or Left(.name, 16) <> "NavigationButton" Then '原来作者这里没有判断是否是NavigationButton,导致一旦对其.top .left属性赋值就会报错
.Top = CC(JJ).TZzz(j).T1 * 1.1
.Left = CC(JJ).TZzz(j).L1 * X
End If
.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

Access软件网QQ交流群 (群号:54525238) 　　　　　　Access源码网店

【打印此文】【关闭窗口】