VB代码获得当前计算机屏幕的分辨率

1、首先：如何获得当前计算机屏幕的分辨率？方法一：PrivateConstSPI_GETWORKAREA=48PrivateDeclareFunctionSystemParametersInfoLib"user32"Alias_"SystemParametersInfoA"(ByValuActionAsLong,ByValuParamAsLong,lpvParamAsAny,ByValfuWinIniAsLong)AsLongPublicTypeRECTLeftAsLong'矩形左上角的X坐标TopAsLong'矩形左上角的Y坐标RightA

2、sLong'矩形右下角的X坐标BottomAsLong'矩形右下角的Y坐标EndTypePrivateSubCommand0_Click()DimlRetAsLongDimapiRECTAsRECTlRet=SystemParametersInfo(SPI_GETWORKAREAv,bNull,apiRECT,0)MsgBoxapiRECT.Right&"X"&apiRECT.BottomEndSub注意，上述得到的是可视屏幕的分辨率，如果任务栏可见，则任务栏的高度排除在外。2.根据取得的分辨率再循环所有的控件依次改变控件属性。方法二：

3、9;*'DECLARATIONSSECTION'*OptionExplicitTypeRECTx1AsLongy1AsLongx2AsLongy2AsLongEndTypeNOTE:Thefollowingdeclarestatementsarecasesensitive.DeclareFunctionGetDesktopWindowLib"User32"()AsLongDeclareFunctionGetWindowRectLib"User32"_(ByValhWndAsLong,rectangleAsRECT)AsLong'*

4、'FUNCTION:GetScreenResolution()''PURPOSE:'Todeterminethecurrentscreensizeorresolution.''RETURN:'Thecurrentscreenresolution.Typicallyoneofthefollowing:'640x480'800x600'1024x768''*FunctionGetScreenResolution()asStringDimRAsRECTDimhWndAsLongDimRetValAsLon

5、ghWnd=GetDesktopWindow()RetVal=GetWindowRect(hWnd,R)GetScreenResolution=(R.x2-R.x1)&"x"&(R.y2-R.y1)EndFunction然后：自动适应电脑显示器各种分辨率2例例一、1. DeclareFunctionGetDesktopWindowLib"USER32"()AsLong2. DeclareFunctionGetWindowRectLib"USER32"(ByValhWndAsLong,rectangleAsRECT)As

6、Long3.4. '这个函数可以使你开发的程序适应各种分辨率，这是我见过的最完美的解决方案！强列推荐5. '如果你是在1024*768的分辨率下写的程序，就把下面那句改为6. 'ConstDesignSize=1024，如果是800*600分7. '辨率下写的，就改为ConstDesignSize=8008. '用法：把下面所有的代码放在一个模块里，在需要适应分辨率的窗体的Load事件里加入：9. 'CallFormResiz_OnOpen(Me)10. '11. 'ConstDesignSize=102412. ConstDes

7、ignSize=80013.14. TypeRECT15. x1AsLong16. y1AsLong17. x2AsLong18. y2AsLong19. EndType20.21. PrivatefrmAsForm22. PrivatectrlAsControl23. PrivateprpAsProperty24. PrivateratAsDouble25. PrivateflgSec26. PrivatexAsLong27. PrivateWinHeightAsLong28. PrivatehWndAsLong29. PrivateretAsLong30. PrivateIAsIntege

8、r31. PrivateRAsRECT32. PrivateSizeLAsLong33. PrivateSizeTAsLong34. PrivateSizeWAsLong35. PrivateSizeHAsLong36.37. '38. PublicFunctionFormResiz_OnOpen(parFrmAsForm,OptionalperSizeLAsLong,OptionalperSizeTAsLong,OptionalperSizeWAsLong,OptionalperSizeHAsLong)39. OnErrorResumeNext40. Setfrm=parFrm41.

9、 '窗口驾驶盘的取得42. hWnd=GetDesktopWindow()43. '现在分辨率取得44. ret=GetWindowRect(hWnd,R)45. '比例计算常例：现在800开发1024800/1024=0.78加倍46. x=(R.x2-R.x1)47. rat=x/DesignSize48. SizeL=0:SizeT=0:SizeW=0:SizeH=049. IfNotIsEmpty(perSizeL)=TrueThen50. SizeL=perSizeL*rat51. SizeT=perSizeT*rat52. SizeW=perSizeW*ra

10、t53. SizeH=perSizeH*rat54. EndIf55.56. '现在分辨率=开发分辨率如果终了57. Ifx=DesignSizeThenExitFunction58. Ifx<DesignSizeThen59. '细小策划时、控制部分表单的次序60. CallChangeCtrl61. CallChengeSec62. CallChangeFrm63. Else64. '大掬取时、表单部分控制的次序65. CallChangeFrm66. CallChengeSec67. CallChangeCtrl68. EndIf69. '最后、表单

11、的使清新70. frm.Refresh71. ExitFunction72. EndFunction73. '74. PrivateSubChangeCtrl()75. OnErrorResumeNext76. ForEachctrlInfrm.Controls77. '选项卡修正，原著没有这段代码,后来有个朋友发现了这个BUG就是选项卡的位置会偏得很厉害78. '所以就加了这段代码来修正79. '主要是"Top","Height","Left","Width"这几个参数的值，根据实

12、际情况适当调整就行了80. Ifctrl.ControlType=123Orctrl.ControlType=124Then81. ForEachprpInctrl.Properties82. SelectC83. Case"FontSize","DatasheetFontHeight"84. prp.Value=Fix(prp.Value*rat+0.5)85. Case"FontWeight"86. prp.Value=Fix(prp.Value*rat)/100)*10087. Case"Top&

13、quot;,"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. EndSelect95. Next96. Else97. ForEachprpInctrl.Properties98. 大小配置关于属性被发现们压缩99.

14、 SelectC100. Case"FontSize","DatasheetFontHeight"101. '通常计算假如行情况之下的+0.5之类的话不需要是但、102. '捆ZoMaft、法。稍微心情坏因为+0.5103. prp.Value=Fix(prp.Value*rat+0.5)104. Case"FontWeight"105. prp.Value=Fix(prp.Value*rat)/100)*100106. Case"Left","Top",&

15、quot;Width","Height"107. prp.Value=Fix(prp.Value*rat)108. EndSelect109. Next110. EndIf111. Next112. EndSub113. '114. PrivateSubChengeSec()115. OnErrorGoToErr_Disp116. '部分转117. flgSec=True118. I=0119. '不存在部分的参照错误化验出终了120. DoUntilflgSec=False121. '部分被发现们高度变更122. frm.Sect

16、ion(I).Height=Fix(frm.Section(I).Height*rat)123. I=I+1124. Loop125. ExitSub126. Err_Disp:127. IfErr=2462Then128. flgSec=False129. ResumeNext130. Else131. MsgBoxErr.Description132. EndIf133. ResumeNext134. EndSub135. '136. PrivateSubChangeFrm()137. OnErrorResumeNext138. IfSizeL>0Then139. DoCmd

17、.MoveSizeSizeL,SizeT,SizeW,SizeH140. Else141. frm.Width=Fix(frm.Width*rat)142. WinHeight=Fix(frm.WindowHeight*rat)143. DoCmd.MoveSize,frm.Width,WinHeight144. EndIf145. EndSub146.例二、窗体在不同的分辨率和屏幕宽度下自动调整大小,并带动其上的控件自动调整大小与相关间距是一个问题,经过摸索,利用窗体的insidewidth和insideHeight属性可以实现该功能,主要代码如下:'-*-*-*-*-*-*-*-*

18、-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*'本模块用于实现窗体自适应分辨率和控件自适应窗体大小功能'本模块的核心函数为gu_SetResize()'开发和调试本模块的时候，均以窗体最大化为动作，其余仅改变分辨率而不修改大小的窗体则没有'参与调试'使用方法见相应函数,注意在设计好后要修改本函数中的几个常数'-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

19、-*-*-*-*PrivateDeclareFunctionGetSystemMetricsLib"user32"(ByValnIndexAsLong)AsLongPrivateConstSM_CXSCREEN=0PrivateConstSM_CYSCREEN=1ConstDesignSizeX=1024'根据实际情况修改ConstDesignSizeY=768As FormDimtFormDimScaleXAsDoubleDimScaleYAsDoubleDimScaleFAsDoublePublicFunctiongu_SetResize(CurrentForm

20、AsForm,_lngOldWidthAsLong,_lngOldHeightAsLong,_OptionalisFirstAsBoolean=True)'-函数名称:gu_SetResize'-功能描述:实现窗体自适应分辨率和控件自适应窗体大小'-输入参数:参数1:CurrentForm要设置的窗体'参数2:lngOldWidth对应窗体的窗口宽度'参数3:lngOldHeight对应窗体的窗口高度'参数4:isFirst调整大小的动作是否窗体加载引起的（load事件将引起一个resize事件）''-返回参数:无'-使用

21、示例:首先应定义三个模块变量，并在load事件与resize事件中分别对三个变量赋值'gu_SetResize用于窗体的resize事件中,全部示例如下：'DimoldFormWidthAsLong'DimoldFormHeightAsLong'DimblnIsFirstAsBooleanPrivateSubForm_Load()oldFormWidth=Me.InsideWidtholdFormHeight=Me.InsideHeightblnIsFirst=TrueDoCmd.MaximizeEndSubPrivateSubForm_Resize()gu_S

22、etResizeMe,oldFormWidth,oldFormHeight,blnIsFirstoldFormWidth=Me.InsideWidtholdFormHeight=Me.InsideHeightblnIsFirst=FalseEndSub'-相关调用:'-使用注意:1、本函数本应该将在当前机器设计时显示的当窗体加载后的第一次resize事件时的窗体大小应写入窗体的tag属性中'但是不知道是何原因，无法写入，所以需要手工填写，这是实现自适应分辨率的关键，必须注意'2、函数主要针对可调边框的窗体，对其他窗体用处暂不明显，故程序加有窗体边框形式的判断语句

23、'-兼容性:2000'-参考资料:'-作者：ACCES叶国网友修改：-（保密，呵呵）'-创建日期;2007-3-10'-图解:As LongAs LongAs IntegerAs StringAs LongAs LongDimXDimYDimiDimstrTagsDimiWidthDimiHeightOnErrorResumeNextSettForm=CurrentForm.Formi=tForm.BorderStyleIfi=0Ori=3ThenExitFunction'取得纵横比例ScaleX=Round(tForm.InsideWidth/

24、lngOldWidth,3)ScaleY=Round(tForm.InsideHeight/lngOldHeight,3)IfNotisFirstThenIfScaleX=1AndScaleY=1ThenExitFunctionEndIf'取得当前分辨率X=GetSystemMetrics(SM_CXSCREEN)Y=GetSystemMetrics(SM_CYSCREEN)'IfX=DesignSizeXAndY=DesignSizeYAndisFirst=TrueThen'tForm.Tag=CStr(tForm.InsideWidth)&"|&q

25、uot;&CStr(tForm.InsideHeight)'EndIf'以下考虑窗体需要调整大小的情形'分辨率与设计相比较有变化且是第一次IfisFirstThenstrTags=tForm.TagIfLen(strTags&"")=0ThenExitFunctioni=InStr(1,strTags,"|",vbTextCompare)iWidth=CLng(Mid(strTags,1,i-1)iHeight=CLng(Mid(strTags,i+1)ScaleX=Round(lngOldWidth/iWidth

26、*ScaleX,3)ScaleY=Round(lngOldHeight/iHeight*ScaleY,3)EndIfIfScaleX=1AndScaleY=1ThenExitFunctionScaleF=(ScaleX+ScaleY)/2'根据调整比例决定控件、节、窗体的变化顺序IfScaleX<1OrScaleY<1Then'缩小Callmu_AdjustControlCallmu_AdjustSectionElse'放大Callmu_AdjustSectionCallmu_AdjustControlEndIf'刷新窗体tForm.RefreshS

27、ettForm=NothingEndFunctionPrivateSubmu_AdjustControl()DimkAsIntegerDimiAsIntegerDimcAsControlDimctrlAsControlOnErrorResumeNext'调整控件ForEachctrlIntForm.Controlsmu_SetCtrolPropertiectrlk=ctrl.ControlTypeSelectCasekCaseacTabCtl'选项卡'对选项卡而言，要对其上的每一页的控件进行修订Dimv1AsTabControlSetv1=ctrl.Objectv1.TabFixedHeight=v1.TabFixedHeight