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

首先：如何获得当前计算机屏幕的分辨率？方法一：Private Const SPI_GETWORKAREA = 48Private Declare Function SystemParametersInfo Lib user32 Alias _ SystemParametersInfoA (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As LongPublic Type RECT Left As Long 矩形左上角的X坐标 Top As Long 矩形左上角的Y坐标 Right As Long 矩形右下角的X坐标 Bottom As Long 矩形右下角的Y坐标End Type Private Sub Command0_Click() Dim lRet As Long Dim apiRECT As RECT lRet = SystemParametersInfo(SPI_GETWORKAREA, vbNull, apiRECT, 0) MsgBox apiRECT.Right & X & apiRECT.BottomEnd Sub注意，上述得到的是可视屏幕的分辨率，如果任务栏可见，则任务栏的高度排除在外。 2.根据取得的分辨率再循环所有的控件依次改变控件属性。方法二：* DECLARATIONS SECTION*Option ExplicitType RECT x1 As Long y1 As Long x2 As Long y2 As LongEnd Type NOTE: The following declare statements are case sensitive.Declare Function GetDesktopWindow Lib User32 () As LongDeclare Function GetWindowRect Lib User32 _ (ByVal hWnd As Long, rectangle As RECT) As Long* FUNCTION: GetScreenResolution() PURPOSE: To determine the current screen size or resolution. RETURN: The current screen resolution. Typically one of the following: 640 x 480 800 x 600 1024 x 768*Function GetScreenResolution () as String Dim R As RECT Dim hWnd As Long Dim RetVal As Long hWnd = GetDesktopWindow() RetVal = GetWindowRect(hWnd, R) GetScreenResolution = (R.x2 - R.x1) & x & (R.y2 - R.y1)End Function然后：自动适应电脑显示器各种分辨率2例例一、1. Declare Function GetDesktopWindow Lib USER32 () As Long 2. Declare Function GetWindowRect Lib USER32 (ByVal hWnd As Long, rectangle As RECT) As Long 3.4. 这个函数可以使你开发的程序适应各种分辨率，这是我见过的最完美的解决方案！强列推荐 5. 如果你是在1024*768的分辨率下写的程序，就把下面那句改为 6. Const DesignSize = 1024，如果是800*600分 7. 辨率下写的，就改为Const DesignSize = 800 8. 用法：把下面所有的代码放在一个模块里，在需要适应分辨率的窗体的Load事件里加入： 9. Call FormResiz_OnOpen(Me) 10. 11. Const DesignSize = 1024 12. Const DesignSize = 800 13.14. Type RECT 15. x1 As Long 16. y1 As Long 17. x2 As Long 18. y2 As Long 19. End Type 20.21. Private frm As Form 22. Private ctrl As Control 23. Private prp As Property 24. Private rat As Double 25. Private flgSec 26. Private x As Long 27. Private WinHeight As Long 28. Private hWnd As Long 29. Private ret As Long 30. Private I As Integer 31. Private R As RECT 32. Private SizeL As Long 33. Private SizeT As Long 34. Private SizeW As Long 35. Private SizeH As Long 36.37. - 38. Public Function FormResiz_OnOpen(parFrm As Form, Optional perSizeL As Long, Optional perSizeT As Long, Optional perSizeW As Long, Optional perSizeH As Long) 39. On Error Resume Next 40. Set frm = parFrm 41. 窗口驾驶盘的取得 42. hWnd = GetDesktopWindow() 43. 现在分辨率取得 44. ret = GetWindowRect(hWnd, R) 45. 比例计算 常例：现在800 开发1024 800/1024 = 0.78加倍 46. x = (R.x2 - R.x1) 47. rat = x / DesignSize 48. SizeL = 0: SizeT = 0: SizeW = 0: SizeH = 0 49. If Not IsEmpty(perSizeL) = True Then 50. SizeL = perSizeL * rat 51. SizeT = perSizeT * rat 52. SizeW = perSizeW * rat 53. SizeH = perSizeH * rat 54. End If 55.56. 现在分辨率开发分辨率如果终了 57. If x = DesignSize Then Exit Function 58. If x 0 Then 139. DoCmd.MoveSize SizeL, 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. End If 145. End Sub 146.例二、窗体在不同的分辨率和屏幕宽度下自动调整大小,并带动其上的控件自动调整大小与相关间距是一个问题,经过摸索,利用窗体的insidewidth和insideHeight属性可以实现该功能,主要代码如下:-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*本模块用于实现窗体自适应分辨率和控件自适应窗体大小功能本模块的核心函数为 gu_SetResize（）开发和调试本模块的时候，均以窗体最大化为动作，其余仅改变分辨率而不修改大小的窗体则没有参与调试使用方法见相应函数,注意在设计好后要修改本函数中的几个常数-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*Private Declare Function GetSystemMetrics Lib user32 (ByVal nIndex As Long) As LongPrivate Const SM_CXSCREEN = 0Private Const SM_CYSCREEN = 1Const DesignSizeX = 1024根据实际情况修改Const DesignSizeY = 768Dim tForm As FormDim ScaleX As DoubleDim ScaleY As DoubleDim ScaleF As DoublePublic Function gu_SetResize(CurrentForm As Form, _ lngOldWidth As Long, _ lngOldHeight As Long, _ Optional isFirst As Boolean = True)-函数名称: gu_SetResize-功能描述: 实现窗体自适应分辨率和控件自适应窗体大小-输入参数: 参数1:CurrentForm 要设置的窗体 参数2:lngOldWidth 对应窗体的窗口宽度 参数3:lngOldHeight 对应窗体的窗口高度 参数4:isFirst 调整大小的动作是否窗体加载引起的(load事件将引起一个resize事件)-返回参数: 无-使用示例: 首先应定义三个模块变量，并在load事件与resize事件中分别对三个变量赋值 gu_SetResize用于窗体的resize事件中,全部示例如下：Dim oldFormWidth As LongDim oldFormHeight As LongDim blnIsFirst As Boolean-Private Sub Form_Load()oldFormWidth = Me.InsideWidtholdFormHeight = Me.InsideHeightblnIsFirst = TrueDoCmd.MaximizeEnd Sub-Private Sub Form_Resize()gu_SetResize Me, oldFormWidth, oldFormHeight, blnIsFirstoldFormWidth = Me.InsideWidtholdFormHeight = Me.InsideHeightblnIsFirst = FalseEnd Sub-相关调用:-使用注意: 1、本函数本应该将在当前机器设计时显示的当窗体加载后的第一次resize事件时的窗体大小应写入窗体的tag属性中 但是不知道是何原因，无法写入，所以需要手工填写，这是实现自适应分辨率的关键，必须注意 2、函数主要针对可调边框的窗体，对其他窗体用处暂不明显，故程序加有窗体边框形式的判断语句-兼 容 性: 2000-参考资料:-作 者: ACCESS中国网友 修改：-(保密,呵呵)-创建日期; 2007-3-10-图 解:- Dim X As Long Dim Y As Long Dim i As Integer Dim strTags As String Dim iWidth As Long Dim iHeight As Long On Error Resume Next Set tForm = CurrentForm.Form i = tForm.BorderStyle If i = 0 Or i = 3 Then Exit Function 取得纵横比例 ScaleX = Round(tForm.InsideWidth / lngOldWidth, 3) ScaleY = Round(tForm.InsideHeight / lngOldHeight, 3) If Not isFirst Then If ScaleX = 1 And ScaleY = 1 Then Exit Function End If 取得当前分辨率 X = GetSystemMetrics(SM_CXSCREEN) Y = GetSystemMetrics(SM_CYSCREEN) If X = DesignSizeX And Y = DesignSizeY And isFirst = True Then tForm.Tag = CStr(tForm.InsideWidth) & | & CStr(tForm.InsideHeight) End If 以下考虑窗体需要调整大小的情形 分辨率与设计相比较有变化且是第一次 If isFirst Then strTags = tForm.Tag If Len(strTags & ) = 0 Then Exit Function 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) End If If ScaleX = 1 And ScaleY = 1 Then Exit Function ScaleF = (ScaleX + ScaleY) / 2 根据调整比例决定控件、节、窗体的变化顺序 If ScaleX 1 Or ScaleY 1 Then 缩小 Call mu_AdjustControl Call mu_AdjustSection Else 放大 Call mu_AdjustSection Call mu_AdjustControl End If 刷新窗体 tForm.Refresh Set tForm = NothingEnd Function-Private Sub mu_AdjustControl() Dim k As Integer Dim i As Integer Dim c As Control Dim ctrl As Control On Error Resume Next 调整控件 For Each ctrl In tForm.Controls mu_SetCtrolPropertie ctrl k = ctrl.ControlType Select Case k Case acTabCtl 选项卡 对选项卡而言，要对其上的每一页的控件进行修订 Dim v1 As TabControl Set v1 = ctrl.Object v1.TabFixedHeight = v1.TabFixedHeight * ScaleY v1.TabFixedWidth = v1.TabFixedWidth * ScaleX For i = 0 To v1.Pages.Count - 1 For Each c In v1.Pages(i).Controls mu_SetCtrolPropertie c Next c Next i Set v1 = Nothing Case 119 状态条 Dim v2 As Panel For Each v2 In ctrl.Panel