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.根據取得的分辨率再循環(huán)所有的控件依次改變控件屬性。方法二：

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. '這個函數可以使你開發(fā)的程序適應各種分辨率，這是我見過的最完美的解決方案！強列推薦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開發(fā)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. '現在分辨率=開發(fā)分辨率如果終了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. '選項卡修正，原著沒有這段代碼,后來有個朋友發(fā)現了這個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. 大小配置關于屬性被發(fā)現們壓縮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. '部分被發(fā)現們高度變更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()'開發(fā)和調試本模塊的時候，均以窗體最大化為動作，其余僅改變分辨率而不修改大小的窗體則沒有'參與調試'使用方法見相應函數,注意在設計好后要修改本函數中的幾個常數'-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

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葉國網友修改：-（保密，呵呵）'-創(chuàng)建日期;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'根據調整比例決定控件、節(jié)、窗體的變化順序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