officeba > 单独文章

---

ACCESS 2007自动加载窗体的方法

ACCESS 2007自动加载窗体的方法，VBA
在宏中的过程autoopen或open 加入form.show 和toolbar.hide== ，
窗体在不同的分辨率和屏幕宽度下自动调整大小,并带动其上的控件自动调整大小与相关间距是一个问题,经过摸索,利用窗体的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

标签: Access VBA   .
另外的方法：做一个打开窗体的宏，把宏名字命改为AUTOEXEC即可

声明：欢迎各大网站转载本站文章，还请保留一条能直接指向本站的超级链接，谢谢！

时间:2010-09-27 09:51:35,点击:65824