VB代码获得当前计算机屏幕的分辨率Word格式.docx
《VB代码获得当前计算机屏幕的分辨率Word格式.docx》由会员分享，可在线阅读，更多相关《VB代码获得当前计算机屏幕的分辨率Word格式.docx（11页珍藏版）》请在冰豆网上搜索。
OptionExplicit
TypeRECT
x1AsLong
y1AsLong
x2AsLong
y2AsLong
EndType
NOTE:
Thefollowingdeclarestatementsarecasesensitive.
DeclareFunctionGetDesktopWindowLib"
User32"
（）AsLong
DeclareFunctionGetWindowRectLib"
_
（ByValhWndAsLong,rectangleAsRECT）AsLong
FUNCTION:
GetScreenResolution（）
PURPOSE:
Todeterminethecurrentscreensizeorresolution.
RETURN:
Thecurrentscreenresolution.Typicallyoneofthefollowing:
640x480
800x600
1024x768
FunctionGetScreenResolution（）asString
DimRAsRECT
DimhWndAsLong
DimRetValAsLong
hWnd=GetDesktopWindow（）
RetVal=GetWindowRect（hWnd,R）
GetScreenResolution=（R.x2-R.x1）&
x"
（R.y2-R.y1）
EndFunction
然后：
自动适应电脑显示器各种分辨率2例
例一、
1.DeclareFunctionGetDesktopWindowLib"
USER32"
（）AsLong
2.DeclareFunctionGetWindowRectLib"
（ByValhWndAsLong,rectangleAsRECT）AsLong
3.
4.'
这个函数可以使你开发的程序适应各种分辨率，这是我见过的最完美的解决方案！
强列推荐
5.'
如果你是在1024*768的分辨率下写的程序，就把下面那句改为
6.'
ConstDesignSize=1024，如果是800*600分
7.'
辨率下写的，就改为ConstDesignSize=800
8.'
用法：
把下面所有的代码放在一个模块里，在需要适应分辨率的窗体的Load事件里加入：
9.'
CallFormResiz_OnOpen（Me）
10.'
11.'
ConstDesignSize=1024
12.ConstDesignSize=800
13.
14.TypeRECT
15.x1AsLong
16.y1AsLong
17.x2AsLong
18.y2AsLong
19.EndType
20.
21.PrivatefrmAsForm
22.PrivatectrlAsControl
23.PrivateprpAsProperty
24.PrivateratAsDouble
25.PrivateflgSec
26.PrivatexAsLong
27.PrivateWinHeightAsLong
28.PrivatehWndAsLong
29.PrivateretAsLong
30.PrivateIAsInteger
31.PrivateRAsRECT
32.PrivateSizeLAsLong
33.PrivateSizeTAsLong
34.PrivateSizeWAsLong
35.PrivateSizeHAsLong
36.
37.'
--------------------------------------------------------------------------------
38.PublicFunctionFormResiz_OnOpen（parFrmAsForm,OptionalperSizeLAsLong,OptionalperSizeTAsLong,OptionalperSizeWAsLong,OptionalperSizeHAsLong）
39.OnErrorResumeNext
40.Setfrm=parFrm
41.'
窗口驾驶盘的取得
42.hWnd=GetDesktopWindow（）
43.'
现在分辨率取得
44.ret=GetWindowRect（hWnd,R）
45.'
比例计算常例：
现在800开发1024800/1024=0.78加倍
46.x=（R.x2-R.x1）
47.rat=x/DesignSize
48.SizeL=0:
SizeT=0:
SizeW=0:
SizeH=0
49.IfNotIsEmpty（perSizeL）=TrueThen
50.SizeL=perSizeL*rat
51.SizeT=perSizeT*rat
52.SizeW=perSizeW*rat
53.SizeH=perSizeH*rat
54.EndIf
55.
56.'
现在分辨率＝开发分辨率如果终了
57.Ifx=DesignSizeThenExitFunction
58.Ifx<
DesignSizeThen
59.'
细小策划时、控制＞部分＞表单的次序
60.CallChangeCtrl
61.CallChengeSec
62.CallChangeFrm
63.Else
64.'
大掬取时、表单＞部分＞控制的次序
65.CallChangeFrm
66.CallChengeSec
67.CallChangeCtrl
68.EndIf
69.'
最后、表单的使清新
70.frm.Refresh
71.ExitFunction
72.EndFunction
73.'
74.PrivateSubChangeCtrl（）
75.OnErrorResumeNext
76.ForEachctrlInfrm.Controls
77.'
选项卡修正，原著没有这段代码，后来有个朋友发现了这个BUG，就是选项卡的位置会偏得很厉害
78.'
所以就加了这段代码来修正
79.'
主要是"
Top"
"
Height"
"
Left"
Width"
这几个参数的值，根据实际情况适当调整就行了
80.Ifctrl.ControlType=123Orctrl.ControlType=124Then
81.ForEachprpInctrl.Properties
82.SelectCaseprp.name
83.Case"
FontSize"
DatasheetFontHeight"
84.prp.Value=Fix（prp.Value*rat+0.5）
85.Case"
FontWeight"
86.prp.Value=Fix（（prp.Value*rat）/100）*100
87.Case"
88.prp.Value=Fix（prp.Value*rat*0.85）
89.'
prp.value=Fix（prp.value*rat）
90.Case"
91.prp.Value=Fix（prp.Value*rat*0.9）
92.Case"
93.prp.Value=Fix（prp.Value*rat*0.7）
94.EndSelect
95.Next
96.Else
97.ForEachprpInctrl.Properties
98.'
大小·
配置关于属性被发现们压缩
99.SelectCaseprp.name
100.Case"
101.'
通常计算假如行…情况之下的+0.5之类的话不需要是…但…、
102.'
捆Zo~Ma办法。
稍微心情坏因为+0.5
103.prp.Value=Fix（prp.Value*rat+0.5）
104.Case"
105.prp.Value=Fix（（prp.Value*rat）/100）*100
106.Case"
107.prp.Value=Fix（prp.Value*rat）
108.EndSelect
109.Next
110.EndIf
111.Next
112.EndSub
113.'
114.PrivateSubChengeSec（）
115.OnErrorGoToErr_Disp
116.'
部分转
117.flgSec=True
118.I=0
119.'
不存在部分的参照错误化验出终了
120.DoUntilflgSec=False
121.'
部分被发现们高度变更
122.frm.Section（I）.Height=Fix（frm.Section（I）.Height*rat）
123.I=I+1
124.Loop
125.ExitSub
126.Err_Disp:
127.IfErr=2462Then
128.flgSec=False
129.ResumeNext
130.Else
131.MsgBoxErr.Description
132.EndIf
133.ResumeNext
134.EndSub
135.'
136.PrivateSubChangeFrm（）
137.OnErrorResumeNext
138.IfSizeL>
0Then
139.DoCmd.MoveSizeSizeL,SizeT,SizeW,SizeH
140.Else
141.frm.Width=Fix（frm.Width*rat）
142.WinHeight=Fix（frm.WindowHeight*rat）
143.DoCmd.MoveSize,,frm.Width,WinHeight
144.EndIf
145.EndSub
146.
例二、
窗体在不同的分辨率和屏幕宽度下自动调整大小,并带动其上的控件自动调整大小与相关间距是一个问题,经过摸索,利用窗体的insidewidth和insideHeight属性可以实现该功能,主要代码如下:
-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
本模块用于实现窗体自适应分辨率和控件自适应窗体大小功能
本模块的核心函数为gu_SetResize（）
开发和调试本模块的时候，均以窗体最大化为动作，其余仅改变分辨率而不修改大小的窗体则没有
参与调试
使用方法见相应函数,注意在设计好后要修改本函数中的几个常数
PrivateDeclareFunctionGetSystemMetricsLib"
（ByValnIndexAsLong）AsLong
PrivateConstSM_CXSCREEN=0
PrivateConstSM_CYSCREEN=1
ConstDesignSizeX=1024'
根据实际情况修改
ConstDesignSizeY=768
DimtForm
AsForm
DimScaleX
AsDouble
DimScaleY
DimScaleF
PublicFunctiongu_SetResize（CurrentFormAsForm,_
lngOldWidthAsLong,_
lngOldHeightAsLong,_
OptionalisFirstAsBoolean=True）
--------------------------------------------------------------
-函数名称:
gu_SetResize
-功能描述:
实现窗体自适应分辨率和控件自适应窗体大小
-输入参数:
参数1:
CurrentForm
要设置的窗体
参数2:
lngOldWidth
对应窗体的窗口宽度
参数3:
lngOldHeight对应窗体的窗口高度
参数4:
isFirst调整大小的动作是否窗体加载引起的（load事件将引起一个resize事件）
-返回参数:
无
-使用示例:
首先应定义三个模块变量，并在load事件与resize事件中分别对三个变量赋值
gu_SetResize用于窗体的resize事件中,全部示例如下：
DimoldFormWidth
AsLong
DimoldFormHeight
DimblnIsFirstAsBoolean
------------
PrivateSubForm_Load（）
oldFormWidth=Me.InsideWidth
oldFormHeight=Me.InsideHeight
blnIsFirst=True
DoCmd.Maximize
-------------
PrivateSubForm_Resize（）
gu_SetResizeMe,oldFormWidth,oldFormHeight,blnIsFirst
blnIsFirst=False
-相关调用:
-使用注意:
1、本函数本应该将在当前机器设计时显示的当窗体加载后的第一次resize事件时的窗体大小应写入窗体的tag属性中
但是不知道是何原因，无法写入，所以需要手工填写，这是实现自适应分辨率的关键，必须注意
2、函数主要针对可调边框的窗体，对其他窗体用处暂不明显，故程序加有窗体边框形式的判断语句
-兼容性:
2000
-参考资料:
-作
者:
ACCESS中国网友修改：
---（保密,呵呵）
-创建日期;
2007-3-10
-图
解:
DimX
DimY
Dimi
AsInteger
DimstrTags
AsString
DimiWidth
DimiHeight
OnErrorResumeNext
SettForm=CurrentForm.Form
i=tForm.BorderStyle
Ifi=0Ori=3ThenExitFunction
'
取得纵横比例
ScaleX=Round（tForm.InsideWidth/lngOldWidth,3）
ScaleY=Round（tForm.InsideHeight/lngOldHeight,3）
IfNotisFirstThen
IfScaleX=1AndScaleY=1ThenExitFunction
EndIf
取得当前分辨率
X=GetSystemMetrics（SM_CXSCREEN）
Y=GetSystemMetrics（SM_CYSCREEN）
IfX=DesignSizeXAndY=DesignSizeYAndisFirst=TrueThen
tForm.Tag=CStr（tForm.InsideWidth）&
|"
CStr（tForm.InsideHeight）
EndIf
以下考虑窗体需要调整大小的情形
分辨率与设计相比较有变化且是第一次
IfisFirstThen
strTags=tForm.Tag
IfLen（strTags&
"
）=0ThenExitFunction
i=InStr（1,strTags,"
vbTextCompare）
iWidth=CLng（Mid（strTags,1,i-1））
iHeight=CLng（Mid（strTags,i+1））
ScaleX=Round（lngOldWidth/iWidth*ScaleX,3）
ScaleY=Round（lngOldHeight/iHeight*ScaleY,3）
ScaleF=（ScaleX+ScaleY）/2
根据调整比例决定控件、节、窗体的变化顺序
If
升级会员 