ACCESS,EXCEL等，使窗口,窗体,程序,自动适应电脑显示器屏幕分辨率

ACCESS,EXCEL等，使窗口,窗体,程序,自动适应电脑显示器屏幕分辨率

2010-11-17 15:21

 

首先：如何获得当前计算机屏幕的分辨率？

方法一：

Private Const SPI_GETWORKAREA = 48
Private Declare Function SystemParametersInfo Lib "user32" Alias _
     "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Public 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.Bottom
End Sub

 

注意，上述得到的是可视屏幕的分辨率，如果任务栏可见，则任务栏的高度排除在外。

 

2.根据取得的分辨率再循环所有的控件依次改变控件属性。

 

 

 

方法二：

'*****************************************************************
' DECLARATIONS SECTION
'*****************************************************************

 

Option Explicit

Type RECT
    x1 As Long
    y1 As Long
    x2 As Long
    y2 As Long
End Type

' NOTE: The following declare statements are case sensitive.

Declare Function GetDesktopWindow Lib "User32" () As Long
Declare 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
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
14. Type RECT
15. x1 As Long
16. y1 As Long
17. x2 As Long
18. y2 As Long
19. End Type
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
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
56. '现在分辨率＝开发分辨率如果终了
57. If x = DesignSize Then Exit Function
58. If x < DesignSize Then
59. '细小策划时、控制＞部分＞表单的次序
60. Call ChangeCtrl
61. Call ChengeSec
62. Call ChangeFrm
63. Else
64. '大掬取时、表单＞部分＞控制的次序
65. Call ChangeFrm
66. Call ChengeSec
67. Call ChangeCtrl
68. End If
69. '最后、表单的使清新
70. frm.Refresh
71. Exit Function
72. End Function
73. '--------------------------------------------------------------------------------
74. Private Sub ChangeCtrl()
75. On Error Resume Next
76. For Each ctrl In frm.Controls
77. '选项卡修正，原著没有这段代码，后来有个朋友发现了这个BUG，就是选项卡的位置会偏得很厉害
78. '所以就加了这段代码来修正
79. '主要是"Top", "Height","Left","Width"这几个参数的值，根据实际情况适当调整就行了
80. If ctrl.ControlType = 123 Or ctrl.ControlType = 124 Then
81. For Each prp In ctrl.Properties
82. Select Case prp.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. End Select
95. Next
96. Else
97. For Each prp In ctrl.Properties
98. '大小·配置关于属性被发现们压缩
99. Select Case prp.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. End Select
109. Next
110. End If
111. Next
112. End Sub
113. '--------------------------------------------------------------------------------
114. Private Sub ChengeSec()
115. On Error GoTo Err_Disp
116. '部分转
117. flgSec = True
118. I = 0
119. '不存在部分的参照错误化验出终了
120. Do Until flgSec = False
121. '部分被发现们高度变更
122. frm.Section(I).Height = Fix(frm.Section(I).Height * rat)
123. I = I + 1
124. Loop
125. Exit Sub
126. Err_Disp:
127. If Err = 2462 Then
128. flgSec = False
129. Resume Next
130. Else
131. MsgBox Err.Description
132. End If
133. Resume Next
134. End Sub
135. '--------------------------------------------------------------------------------
136. Private Sub ChangeFrm()
137. On Error Resume Next
138. If SizeL > 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

 

例二、

窗体在不同的分辨率和屏幕宽度下自动调整大小,并带动其上的控件自动调整大小与相关间距是一个问题,经过摸索,利用窗体的insidewidth和insideHeight属性可以实现该功能,主要代码如下:

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

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Const DesignSizeX = 1024'根据实际情况修改
Const DesignSizeY = 768

Dim tForm                     As Form

Dim ScaleX                    As Double
Dim ScaleY                    As Double
Dim ScaleF                    As Double
Public 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 Long
'Dim oldFormHeight             As Long
'Dim blnIsFirst As Boolean

'------------
'Private Sub Form_Load()

'oldFormWidth = Me.InsideWidth
'oldFormHeight = Me.InsideHeight
'blnIsFirst = True

'DoCmd.Maximize

'End Sub

'-------------
'Private Sub Form_Resize()

'gu_SetResize Me, oldFormWidth, oldFormHeight, blnIsFirst

'oldFormWidth = Me.InsideWidth
'oldFormHeight = Me.InsideHeight
'blnIsFirst = False

'End 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 = Nothing
End 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.Panels
                    v2.Width = v2.Width + ScaleX
                Next v2
                'Case actoolbar

            Case Else
        End Select
    Next ctrl

    Set ctrl = Nothing
    Set c = Nothing
End Sub
'--------------------------------------------------------------------------------
Private Sub mu_AdjustSection()

    Dim k                     As Integer

    On Error Resume Next
   
    For k = 0 To 2
        tForm.Section(k).Height = Fix(tForm.Section(k).Height * ScaleY)
    Next
End Sub
Private Function mu_SetCtrolPropertie(tempCtrl As Variant)
    Dim prp                   As Property

    On Error Resume Next

    For Each prp In tempCtrl.Properties
        Select Case prp.Name
            Case "FontSize", "DatasheetFontHeight"
                prp.Value = Fix(prp.Value * ScaleF)
            Case "FontWeight"
                prp.Value = Fix((prp.Value * ScaleF) / 100) * 100
            Case "Top", "Height"
                prp.Value = Fix(prp.Value * ScaleY)
            Case "Left", "Width"
                prp.Value = Fix(prp.Value * ScaleX)
        End Select
    Next prp

    Set prp = Nothing
End Function