让控件自适应屏幕分辨率
这个函数可以使你开发的程序适应各种分辨率,这是我见过的最完美的解决方 案!强列推荐☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆ 如果你是在1024*768的分辨率下写的程序,就把下面那句改为 Const DesignSize = 1024,如果是800*600分 辨率下写的,就改为Const DesignSize = 800 用法:把下面所有的代码放在一个模块里,在需要适应分辨率的窗体的Load事 件里加入Call FormResiz_OnOpen(Me) ☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆ Const DesignSize = 1024 Const DesignSize = 800 ☆★☆★☆★☆★☆★☆★☆★☆★☆★ 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) 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 ******************************************************************************************* 选项卡修正,原著没有这段代码,后来有个朋友发现了这个BUG,就是选项卡的位置会偏得很厉害 所以就加了这段代码来修正 主要是"Top", "Height","Left","Width"这几个参数的值,根据实际情况适当调整就行了 If ctrl.ControlType = 123 Or ctrl.ControlType = 124 Then For Each prp In ctrl.Properties Select Case prp.Name Case "FontSize", "DatasheetFontHeight" prp.Value = Fix(prp.Value * rat + 0.5) Case "FontWeight" prp.Value = Fix((prp.Value * rat) / 100) * 100 Case "Top", "Height" prp.Value = Fix(prp.Value * rat * 0.85) prp.Value = Fix(prp.Value * rat) Case "Left" prp.Value = Fix(prp.Value * rat * 0.9) Case "Width" prp.Value = Fix(prp.Value * rat * 0.7) End Select Next prp ******************************************************************************************** Else 属性转 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.Value = Fix(prp.Value * rat) 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 * rat) 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 * rat) DoCmd.MoveSize , , frm.Width, WinHeight End If End Sub
--------------------------------------------------------------------------------
相关文章
没有相关文章
|