如何检测MS Access VBA窗体是否完全在屏幕内可见？

部分用户反馈部分MS Access窗体无法在屏幕上完整显示，我们编写了一个窗体打开后调用的检测函数，用于识别过宽或过高的窗体（重点检测用户投诉的窗体右下角区域）。但当前函数存在异常：仅在窗体严重超出时才触发调试断点（Stop），轻微超出的场景无法被检测到。

检测主函数 #

Private Sub CheckObFormVollstaendigSichtbar(ByVal par_form As Form)
  
  Dim formRight As Integer
  formRight = par_form.WindowLeft + par_form.WindowWidth
  
  Dim formBottom As Integer
  formBottom = par_form.WindowTop + par_form.WindowHeight

  With fn_getAccessClientRect
    
    If .BottomRight.x < formRight Then
      'Too broad
      Stop
    End If
    
    If .BottomRight.Y < formBottom Then
      'Too high
      Stop
    End If
    
  End With
End Sub

辅助函数 #

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long

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

Public Function fn_getAccessClientRect() As ZRechteckClass

  Dim mdiRect As Rect

  Call GetClientRect(Application.hWndAccessApp, mdiRect)

  Set fn_getAccessClientRect = ZRechteck(fn_pixelsToTwips(mdiRect.x1, DIRECTION_HORIZONTAL), _
                                         fn_pixelsToTwips(mdiRect.y1, DIRECTION_VERTICAL), _
                                         fn_pixelsToTwips(mdiRect.x2, DIRECTION_HORIZONTAL), _
                                         fn_pixelsToTwips(mdiRect.y2, DIRECTION_VERTICAL))

End Function

Public Function fn_pixelsToTwips(lPixels As Long, lDirection As Long) As Long

  Dim lDeviceHandle As Long
  Dim lPixelsPerInch As Long

  lDeviceHandle = GetDC(0)

  If lDirection = DIRECTION_HORIZONTAL Then
    lPixelsPerInch = GetDeviceCaps(lDeviceHandle, LOGPIXELSX)
  Else
    lPixelsPerInch = GetDeviceCaps(lDeviceHandle, LOGPIXELSY)
  End If

  lDeviceHandle = ReleaseDC(0, lDeviceHandle)
  
  fn_pixelsToTwips = lPixels * 1440 / lPixelsPerInch

End Function

1. 坐标系不匹配：现有代码中，fn_getAccessClientRect返回的是Access主窗口客户区的内部相对坐标（以主窗口客户区左上角为原点），但窗体的WindowLeft/WindowTop是相对于屏幕左上角的坐标。两者坐标系不一致，导致对比逻辑完全错误。
2. 数据类型溢出风险：formRight和formBottom使用Integer类型，而twips值可能超过其最大值（32767），导致计算结果错误。

修正的辅助函数（补全必要声明） #

' 补全API声明与类型定义
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

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

Type POINTAPI
    x As Long
    y As Long
End Type

Const DIRECTION_HORIZONTAL As Long = 0
Const DIRECTION_VERTICAL As Long = 1
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90

Public Function fn_getAccessClientRect() As ZRechteckClass
  Dim mdiRect As Rect
  Dim clientTopLeft As POINTAPI
  Dim clientBottomRight As POINTAPI
  
  ' 获取主窗口客户区的内部矩形
  Call GetClientRect(Application.hWndAccessApp, mdiRect)
  
  ' 将客户区左上角(0,0)转换为屏幕坐标
  clientTopLeft.x = 0
  clientTopLeft.y = 0
  Call ClientToScreen(Application.hWndAccessApp, clientTopLeft)
  
  ' 将客户区右下角(x2,y2)转换为屏幕坐标
  clientBottomRight.x = mdiRect.x2
  clientBottomRight.y = mdiRect.y2
  Call ClientToScreen(Application.hWndAccessApp, clientBottomRight)
  
  ' 转换为twips并返回矩形对象
  Set fn_getAccessClientRect = ZRechteck( _
    fn_pixelsToTwips(clientTopLeft.x, DIRECTION_HORIZONTAL), _
    fn_pixelsToTwips(clientTopLeft.y, DIRECTION_VERTICAL), _
    fn_pixelsToTwips(clientBottomRight.x, DIRECTION_HORIZONTAL), _
    fn_pixelsToTwips(clientBottomRight.y, DIRECTION_VERTICAL) _
  )
End Function

Public Function fn_pixelsToTwips(lPixels As Long, lDirection As Long) As Long
  Dim lDeviceHandle As Long
  Dim lPixelsPerInch As Long

  lDeviceHandle = GetDC(0)
  If lDirection = DIRECTION_HORIZONTAL Then
    lPixelsPerInch = GetDeviceCaps(lDeviceHandle, LOGPIXELSX)
  Else
    lPixelsPerInch = GetDeviceCaps(lDeviceHandle, LOGPIXELSY)
  End If
  lDeviceHandle = ReleaseDC(0, lDeviceHandle)
  
  fn_pixelsToTwips = lPixels * 1440 / lPixelsPerInch
End Function

修正的检测主函数 #

Private Sub CheckObFormVollstaendigSichtbar(ByVal par_form As Form)
  ' 改用Long类型避免溢出
  Dim formRight As Long
  formRight = par_form.WindowLeft + par_form.WindowWidth
  
  Dim formBottom As Long
  formBottom = par_form.WindowTop + par_form.WindowHeight

  With fn_getAccessClientRect
    ' 对比窗体右下角是否超出主窗口客户区的屏幕坐标
    If .BottomRight.x < formRight Then
      ' 窗体过宽，右下角超出可视区域
      Stop
    End If
    
    If .BottomRight.y < formBottom Then
      ' 窗体过高，右下角超出可视区域
      Stop
    End If
  End With
End Sub

1. 统一坐标系：通过ClientToScreen将Access主窗口客户区的坐标转换为屏幕坐标，确保与窗体的WindowLeft/WindowTop坐标系一致，对比逻辑准确。
2. 修复数据类型：将formRight和formBottom改为Long类型，避免twips值过大导致的溢出错误。
3. 补全必要声明：添加了ClientToScreen等API的声明以及POINTAPI类型定义，确保函数正常运行。

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