|
一个日本人写的模块
'☆★☆★☆★☆★☆★☆★☆★☆★☆★
'开发分辨率不变的设置 捆您的开发状态!
Const DesignSize = 1024
'☆★☆★☆★☆★☆★☆★☆★☆★☆★
'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
'国标码宣言
Dim frm As Form
Dim ctrl As Control
Dim prp As Property
Dim rat As Double
Dim flgSec
Dim X 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)
'设计本身变图、开偶尔大小调整(现在的显示器分辨率使合)
'表单的开集会从Call请
'参数关于
' Me = 表单那个东西
' Optional参数 = 元(原来)々 Docmd.MoveSize使地方与大小指定正在做表单的时、
' 那个价也现在分辨率合不计算问稀有的祈祷、那样的表单
' Docmd.MoveSize何况……乎持马缰的手、这函数呼唤奇怪后参数把……粘上请
' 常例) Call FormResiz_OnOpen(Me, 113, 113, 11623, 7371)
' Docmd.MoveSize使没表单
' 常例) Call FormResiz_OnOpen(Me)
' 泥搂。
'控制的属性直接指定后背图格尔号格尔号正在转的是、
'变更了不抚养时或、另外能变更属性有酿不弄清为了
'各自调整的柯托皮
'##留意标点(叫做吗、暧昧叫做吗、分辩叫做吗、、、的部分^^;)
' ·最初、普通的显示器开发底下应该……、液晶显示器表示了只有
' 不管怎么样表示神色瓜子久那っ又……又使安静下来。
' 的因为、因此弹OK这种东西事情没想。
' 使用腹足类炉缸人各自调整请。
' ·1024开发底下应该……800的分辨率表示这种东西事情、「细小策划」结。
' 1024字体大小10之类的话控制、单纯计算78%细小策划结因为
' 字体大小7.8要点腹足类里磨(吉ゃ搓)。祈望周知。
' ##叫做意义「参阅文献」作为使请篱笆 m(_ _;)m
'
On Error Resume Next
Set frm = parFrm
'窗口驾驶盘的取得
hWnd = GetDesktopWindow()
'现在分辨率取得
ret = GetWindowRect(hWnd, R)
'比例计算 常例:现在800 开发1024 800/1024 = 0.78加倍
X = (R.x2 - R.x1)
rat = X / DesignSize
SizeL = 0: SizeT = 0: SizeW = 0: SizeH = 0
If Not IsEmpty(perSizeL) = True Then
SizeL = perSizeL * rat
SizeT = perSizeT * rat
SizeW = perSizeW * rat
SizeH = perSizeH * rat
End If
'现在分辨率=开发分辨率如果终了
If X = DesignSize Then Exit Function
If X < DesignSize Then
'细小策划时、控制>部分>表单的次序
Call ChangeCtrl
Call ChengeSec
Call ChangeFrm
Else
'大掬取时、表单>部分>控制的次序
Call ChangeFrm
Call ChengeSec
Call ChangeCtrl
End If
'最后、表单的使清新
frm.Refresh
Exit Function
End Function
'--------------------------------------------------------------------------------
Private Sub ChangeCtrl()
On Error Resume Next
'控制转
For Each ctrl In frm.Controls
'属性转
For Each prp In ctrl.Properties
'大小·配置关于属性被发现们压缩
Select Case prp.Name
Case "FontSize", "DatasheetFontHeight"
'通常计算假如行…情况之下的 +0.5 之类的话不需要是…但…、
'捆Zo~Ma办法。稍微心情坏因为 +0.5
prp.Value = Fix(prp.Value * rat + 0.5)
Case "FontWeight"
prp.Value = Fix((prp.Value * rat) / 100) * 100
Case "Left", "Top", "Width", "Height"
prp.Va |
|