[分享]根据屏幕分辨率自动调整窗体大小以及让控件自适应屏幕分辨率

eyewitnes · 发表于 2007-6-9 19:31:00

根据屏幕分辨率自动调整窗体大小

Option Compare Database

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Private Const SM_CXSCREEN = 0

Private Const SM_CYSCREEN = 1

Private Sub Form_Open(Cancel As Integer)

Dim x As Long, y As Long, a As Long, b As Long

x = GetSystemMetrics(SM_CXSCREEN)

y = GetSystemMetrics(SM_CYSCREEN)

a = 10000 / 800 * x

b = 7000 / 600 * y

DoCmd.MoveSize 1134, 1134, a, b

End Sub

获得系统的屏幕区域大小

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Private Sub Command0_Click()
Dim x As Long, y As Long
x = GetSystemMetrics(SM_CXSCREEN)
y = GetSystemMetrics(SM_CYSCREEN)
MsgBox x & " " & y
End Sub

让控件自适应屏幕分辨率2
来源：ACCESS爱好者

'这个函数可以使你开发的程序适应各种分辨率，这是我见过的最完美的解决方案！强列推荐

''如果你是在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 ChangeCt