如何让MS Access窗体仅在Access窗口内显示并适配屏幕分辨率？

一、确保窗体在活动显示器的Access主窗口内打开 #

你现有代码错误地引用了Screen.ActiveForm（指向当前打开的弹出窗体本身），导致无法锚定到Access主窗口。需要通过Windows API获取主窗口的位置与尺寸，再将弹出窗体定位到该范围内：

步骤1：添加API声明（放入标准模块） #

Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

步骤2：修改窗体的OnOpen事件代码 #

Private Sub Form_Open(Cancel As Integer)
    Dim accWindowRect As RECT
    Dim accLeft As Long, accTop As Long, accWidth As Long, accHeight As Long
    Dim formWidth As Long, formHeight As Long
    
    ' 获取Access主窗口的位置和尺寸
    Call GetWindowRect(Application.hWndAccessApp, accWindowRect)
    accLeft = accWindowRect.Left
    accTop = accWindowRect.Top
    accWidth = accWindowRect.Right - accWindowRect.Left
    accHeight = accWindowRect.Bottom - accWindowRect.Top
    
    ' 获取当前弹出窗体的原始尺寸
    formWidth = Me.WindowWidth
    formHeight = Me.WindowHeight
    
    ' 将窗体定位在Access主窗口中心（可自行调整为左上角偏移等逻辑）
    DoCmd.MoveSize _
        Left:=accLeft + (accWidth - formWidth) / 2, _
        Top:=accTop + (accHeight - formHeight) / 2, _
        Width:=formWidth, _
        Height:=formHeight
End Sub

这段代码会强制弹出窗体在Access主窗口范围内显示，确保不会跑到其他显示器。

二、自动适配屏幕分辨率 #

针对不同分辨率的屏幕，需根据当前显示器的参数动态调整窗体及控件的大小，以下是基于3840×2160设计基准的适配方案：

步骤1：获取当前显示器的分辨率（放入标准模块） #

Declare PtrSafe Function GetSystemMetricsForDpi Lib "user32" (ByVal nIndex As Long, ByVal dpi As Integer) As Long
Declare PtrSafe Function GetDpiForWindow Lib "user32" (ByVal hWnd As LongPtr) As Integer

Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1

' 获取Access窗口所在显示器的真实分辨率（含DPI缩放）
Function GetCurrentDisplayResolution() As Variant
    Dim dpi As Integer
    Dim screenWidth As Long, screenHeight As Long
    
    dpi = GetDpiForWindow(Application.hWndAccessApp)
    screenWidth = GetSystemMetricsForDpi(SM_CXSCREEN, dpi)
    screenHeight = GetSystemMetricsForDpi(SM_CYSCREEN, dpi)
    
    GetCurrentDisplayResolution = Array(screenWidth, screenHeight)
End Function

步骤2：在窗体加载时动态调整布局 #

Private Sub Form_Load()
    Dim designWidth As Long, designHeight As Long
    Dim currentRes As Variant
    Dim scaleRatio As Double
    Dim ctl As Control
    
    ' 设计时的基准分辨率
    designWidth = 3840
    designHeight = 2160
    
    ' 获取当前显示器分辨率
    currentRes = GetCurrentDisplayResolution()
    
    ' 取宽高比例中的较小值，避免控件变形
    scaleRatio = WorksheetFunction.Min(currentRes(0)/designWidth, currentRes(1)/designHeight)
    
    ' 调整窗体大小
    Me.WindowWidth = Me.WindowWidth * scaleRatio
    Me.WindowHeight = Me.WindowHeight * scaleRatio
    
    ' 批量调整控件的位置、大小和字体
    For Each ctl In Me.Controls
        ctl.Left = ctl.Left * scaleRatio
        ctl.Top = ctl.Top * scaleRatio
        ctl.Width = ctl.Width * scaleRatio
        ctl.Height = ctl.Height * scaleRatio
        
        If TypeOf ctl Is Label Or TypeOf ctl Is TextBox Or TypeOf ctl Is CommandButton Then
            ctl.FontSize = ctl.FontSize * scaleRatio
        End If
    Next ctl
End Sub

额外注意事项 #

• 所有弹出窗体都需套用上述逻辑，避免出现跨显示器跳转；
• 在Access选项中开启「高DPI缩放适配」（文件→选项→常规→高DPI缩放适配），适配高分辨率屏幕；
• 测试时需覆盖不同分辨率、不同DPI缩放比例的场景。

内容的提问来源于stack exchange，提问作者DevNoob