静态更改所有窗体设计分辨率。

memphis230

由于设计分辨率和运行分辨率不一致，导致精心设计的程序界面不完美，采用其他大神的动态分辨率显示，总有缺陷，尤其是对不最大化的窗体，还有每次打开窗体要刷新一次，整得屏幕一闪一闪的。更因为每个窗口要调用，加一行代码，对上百窗体的大程序来说，恶梦连连。本程序可彻底更改你的设计分辨率，让你的代码完美呈现，还可以随心所欲地改回去。
顺便贴上修改过的动态分辨率适应，解决了数据表子窗体问题和选项卡乱跑问题。
Option Compare Database
'API宣言
Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Function GetWindowRect Lib "User32" (ByVal hWnd As Long, rectangle As RECT) As Long

'Type宣言
Type RECT
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type

'如果你是在1024*768的分辨率下写的程序，就把下面那句改为
'Const DesignSize = 1024，如果是800*600分
'辨率下写的，就改为Const DesignSize = 800
'
Const DesignSize = 1440
'国标码宣言
Dim frm As Form
Dim ctrl As Control
Dim prp As Property
Dim rat As Double
Dim rat1 As Double
Dim flgSec
Dim X As Long
Dim Y As Long
Dim WinHeight As Long
Dim hWnd As Long
Dim ret As Long
Dim i As Integer
Dim R As RECT
Dim SizeL As Long
Dim SizeT As Long
Dim SizeW As Long
Dim SizeH As Long

'--------------------------------------------------------------------------------
Public Function FormResiz_OnOpen(parFrm As Form, Optional perSizeL As Long, Optional perSizeT As Long, Optional perSizeW As Long, Optional perSizeH As Long)
On Error Resume Next
Set frm = parFrm
'窗口驾驶盘的取得
hWnd = GetDesktopWindow()
'现在分辨率取得
ret = GetWindowRect(hWnd, R)
'比例计算 常例：现在800 开发1024 800/1024 = 0.78加倍
X = (R.x2 - R.x1)
Y = (R.y2 - R.y1)
rat = X / 1440
rat1 = Y / 900
SizeL = 0: SizeT = 0: SizeW = 0: SizeH = 0
If Not IsEmpty(perSizeL) = True Then
SizeL = perSizeL * rat
SizeT = perSizeT * rat1
SizeW = perSizeW * rat
SizeH = perSizeH * rat1
End If

'现在分辨率＝开发分辨率如果终了
If X = 1440 Then Exit Function
If Y < 900 Then
'细小策划时、控制＞部分＞表单的次序
Call ChangeCtrl
Call ChengeSec
Call ChangeFrm
Else
'大掬取时、表单＞部分＞控制的次序
Call ChangeFrm
Call ChengeSec
Call ChangeCtrl
End If
Call ChangeZct
'最后、表单的使清新
frm.Refresh
Exit Function
End Function
'--------------------------------------------------------------------------------
Private Sub ChangeCtrl()
On Error Resume Next
'控制转
For Each ctrl In frm.Controls
'Debug.Print ctrl.ControlType, ctrl.Name
If ctrl.ControlType <> 124 Then    '选项卡中页ControlType=124，原著没有这段代码，就是选项卡的位置会偏得很厉害。
For Each prp In ctrl.Properties
Select Case prp.Name
Case "FontSize", "DatasheetFontHeight"
prp.Value = Fix(prp.Value * rat1)
Case "FontWeight"
prp.Value = Fix((prp.Value * rat1) / 100) * 100
Case "Left", "Width"
prp.Value = Fix(prp.Value * rat * 1)
Case "Top", "Height"
prp.Value = Fix(prp.Value * rat1 * 1)
End Select
Next prp
End If
Next ctrl
End Sub
'--------------------------------------------------------------------------------
Private Sub ChengeSec()
On Error GoTo Err_Disp
'部分转
flgSec = True
i = 0
'不存在部分的参照错误化验出终了
Do Until flgSec = False
'部分被发现们高度变更
frm.Section(i).Height = Fix(frm.Section(i).Height * rat1)
i = i + 1
Loop
Exit Sub
Err_Disp:
If Err = 2462 Then
flgSec = False
Resume Next
Else
MsgBox Err.Description
End If
Resume Next
End Sub
'--------------------------------------------------------------------------------
Private Sub ChangeFrm()
On Error Resume Next
'表单的大小变更
'Optional参数数值渡下次收拾ば、而且使合（计算正在完毕）
If SizeL > 0 Then
DoCmd.MoveSize SizeL, SizeT, SizeW, SizeH
Else
'特别是指定啊假如踢?变更了表单的大小表示
'表单的属性（宽与高度）
frm.Width = Fix(frm.Width * rat)
WinHeight = Fix(frm.WindowHeight * rat1)
DoCmd.MoveSize , , frm.Width, WinHeight
End If
End Sub

Public Function ztChange(parFrm As Form)
'------------------------------处理数据表子窗体，可单独调用
On Error Resume Next
Set frm = parFrm
hWnd = GetDesktopWindow()
ret = GetWindowRect(hWnd, R)
X = (R.x2 - R.x1)
If X = 1440 Then Exit Function
rat = X / 1440
   Call ChangeZct
Exit Function
End Function
Private Sub ChangeZct()
On Error Resume Next
Dim zctCtl As Control
For Each ctrl In frm.Controls
If ctrl.ControlType = 112 And Y > 900 Then
   ctrl.Form.DatasheetFontHeight = Round(ctrl.Form.DatasheetFontHeight * rat, 0)
   For Each zctCtl In ctrl.Form
        If TypeOf zctCtl Is TextBox Then
           zctCtl.ColumnWidth = Round(zctCtl.ColumnWidth * rat, 0)
        End If
   Next zctCtl
Else
   For Each zctCtl In ctrl.Form
        If TypeOf zctCtl Is TextBox Then
           zctCtl.ColumnWidth = -2
        End If
   Next zctCtl
End If
Next ctrl
End Sub

roych

支持一下。

linlancxh

好的 我正需要

风中漫步

修改过吗?感觉效果怎样?

zpy2

不错 顶

fjh

正在下载学习中

memphis240

风中漫步 发表于 2015-4-12 10:09
修改过吗?感觉效果怎样?

那是：爽翻，安逸得板。