VB代码获得当前计算机屏幕的分辨率.docx
- 文档编号:5706753
- 上传时间:2022-12-31
- 格式:DOCX
- 页数:11
- 大小:20.16KB
VB代码获得当前计算机屏幕的分辨率.docx
《VB代码获得当前计算机屏幕的分辨率.docx》由会员分享,可在线阅读,更多相关《VB代码获得当前计算机屏幕的分辨率.docx(11页珍藏版)》请在冰豆网上搜索。
VB代码获得当前计算机屏幕的分辨率
首先:
如何获得当前计算机屏幕的分辨率?
方法一:
PrivateConstSPI_GETWORKAREA=48
PrivateDeclareFunctionSystemParametersInfoLib"user32"Alias_
"SystemParametersInfoA"(ByValuActionAsLong,ByValuParamAsLong,lpvParamAsAny,ByValfuWinIniAsLong)AsLong
PublicTypeRECT
LeftAsLong'矩形左上角的X坐标
TopAsLong'矩形左上角的Y坐标
RightAsLong'矩形右下角的X坐标
BottomAsLong'矩形右下角的Y坐标
EndType
PrivateSubCommand0_Click()
DimlRetAsLong
DimapiRECTAsRECT
lRet=SystemParametersInfo(SPI_GETWORKAREA,vbNull,apiRECT,0)
MsgBoxapiRECT.Right&"X"&apiRECT.Bottom
EndSub
注意,上述得到的是可视屏幕的分辨率,如果任务栏可见,则任务栏的高度排除在外。
2.根据取得的分辨率再循环所有的控件依次改变控件属性。
方法二:
'*****************************************************************
'DECLARATIONSSECTION
'*****************************************************************
OptionExplicit
TypeRECT
x1AsLong
y1AsLong
x2AsLong
y2AsLong
EndType
'NOTE:
Thefollowingdeclarestatementsarecasesensitive.
DeclareFunctionGetDesktopWindowLib"User32"()AsLong
DeclareFunctionGetWindowRectLib"User32"_
(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"USER32"(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 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"Top","Height" 88.prp.Value=Fix(prp.Value*rat*0.85) 89.'prp.value=Fix(prp.value*rat) 90.Case"Left" 91.prp.Value=Fix(prp.Value*rat*0.9) 92.Case"Width" 93.prp.Value=Fix(prp.Value*rat*0.7) 94.EndSelect 95.Next 96.Else 97.ForEachprpInctrl.Properties 98.'大小·配置关于属性被发现们压缩 99.SelectCaseprp.name 100.Case"FontSize","DatasheetFontHeight" 101.'通常计算假如行…情况之下的+0.5之类的话不需要是…但…、 102.'捆Zo~Ma办法。 稍微心情坏因为+0.5 103.prp.Value=Fix(prp.Value*rat+0.5) 104.Case"FontWeight" 105.prp.Value=Fix((prp.Value*rat)/100)*100 106.Case"Left","Top","Width","Height" 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"user32"(ByValnIndexAsLong)AsLong PrivateConstSM_CXSCREEN=0 PrivateConstSM_CYSCREEN=1 ConstDesignSizeX=1024'根据实际情况修改 ConstDesignSizeY=768 DimtForm AsForm DimScaleX AsDouble DimScaleY AsDouble DimScaleF AsDouble 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 AsLong 'DimblnIsFirstAsBoolean '------------ 'PrivateSubForm_Load() 'oldFormWidth=Me.InsideWidth 'oldFormHeight=Me.InsideHeight 'blnIsFirst=True 'DoCmd.Maximize 'EndSub '------------- 'PrivateSubForm_Resize() 'gu_SetResizeMe,oldFormWidth,oldFormHeight,blnIsFirst 'oldFormWidth=Me.InsideWidth 'oldFormHeight=Me.InsideHeight 'blnIsFirst=False 'EndSub '-相关调用: '-使用注意: 1、本函数本应该将在当前机器设计时显示的当窗体加载后的第一次resize事件时的窗体大小应写入窗体的tag属性中 ' 但是不知道是何原因,无法写入,所以需要手工填写,这是实现自适应分辨率的关键,必须注意 ' 2、函数主要针对可调边框的窗体,对其他窗体用处暂不明显,故程序加有窗体边框形式的判断语句 '-兼容性: 2000 '-参考资料: '-作 者: ACCESS中国网友修改: ---(保密,呵呵) '-创建日期; 2007-3-10 '-图 解: '-------------------------------------------------------------- DimX AsLong DimY AsLong Dimi AsInteger DimstrTags AsString DimiWidth AsLong DimiHeight AsLong 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) EndIf IfScaleX=1AndScaleY=1ThenExitFunction ScaleF=(ScaleX+ScaleY)/2 '根据调整比例决定控件、节、窗体的变化顺序 If
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- VB 代码 获得 当前 计算机 屏幕 分辨率