Question

关于API调用和适用于32位和64位系统的TWIPS /像素问题的问题。我想要一个弹出窗体显示在鼠标指针的位置。我的解决方案有点工作（至少没有崩溃），但似乎没有计算出正确的位置。

'API Calls
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPtr

Private Declare PtrSafe Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As RECT_Type) As LongPtr

Private Declare PtrSafe Function apiGetDC Lib "user32" Alias "GetDC" (ByVal hWnd As Long) As LongPtr

Private Declare PtrSafe Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hDC As LongPtr, ByVal nIndex As Long) As LongPtr

Private Declare PtrSafe Function apiReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hWnd As Long, ByVal hDC As LongPtr) As LongPtr

Private Const TWIPSPERINCH = 1440
Private Const WU_LOGPIXELSX = 88
Private Const WU_LOGPIXELSY = 90

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Type RECT_Type
    left As Long
    top As Long
    right As Long
    bottom As Long
 End Type

Public Function GetXCursorPos() As Long
    Dim pt As POINTAPI
    GetCursorPos pt
    GetXCursorPos = CLng(pt.X)
End Function

Public Function GetYCursorPos() As Long
    Dim pt As POINTAPI
    GetCursorPos pt
    GetYCursorPos = pt.Y
End Function

Public Function ConvertPIXELSToTWIPS(lPixel As Long, _
                                 lDirection As Long) As Long

    Dim hDC As LongPtr
    Dim hWnd As Long
    Dim RetVal As LongPtr
    Dim PIXELSPERINCH

    hDC = apiGetDC(0)

    ' Horizontal
    If (lDirection = 0) Then
        PIXELSPERINCH = apiGetDeviceCaps(hDC, WU_LOGPIXELSX)
    ' Vertical
    Else
        PIXELSPERINCH = apiGetDeviceCaps(hDC, WU_LOGPIXELSY)
    End If

    RetVal = apiReleaseDC(0, hDC)

    ConvertPIXELSToTWIPS = (lPixel / PIXELSPERINCH) * TWIPSPERINCH

End Function

Function ConvertTwipsToPixels(lTwips As Long, _
                          lDirection As Long) As Long

    Dim lDC As LongPtr
    Dim lPixelsPerInch As LongPtr

    lDC = apiGetDC(0)

    ' Horizontal
    If (lDirection = 0) Then
        lPixelsPerInch = apiGetDeviceCaps(lDC, WU_LOGPIXELSX)
    ' Vertical
    Else
        lPixelsPerInch = apiGetDeviceCaps(lDC, WU_LOGPIXELSY)
    End If

    lDC = apiReleaseDC(0, lDC)

    ConvertTwipsToPixels = (lTwips / TWIPSPERINCH) * lPixelsPerInch

End Function

表单本身将像这样打开

Private Sub Form_Load()
    Dim lWidthPixel As Long
    Dim lHeightPixel As Long

    Dim lWidthTwips As Long
    Dim lHeightTwips As Long

    lWidthPixel = modAPI.GetXCursorPos
    lHeightPixel = modAPI.GetYCursorPos

    lWidthTwips = ConvertPIXELSToTWIPS(lWidthPixel, 0)
    lHeightTwips = ConvertPIXELSToTWIPS(lHeightPixel, 1)
    Me.Move left:=lWidthTwips, top:=lHeightTwips
 End Sub

我必须承认，在编程方面，我的编程技巧必须投降，特别是在不得不兼顾long和longptr时。上面的代码是从不同的来源收集的。非常感谢任何帮助

非常感谢

乔恩

Answer 1

未正确计算位置，因为您没有考虑事实GetCursorPos返回屏幕坐标，而Form.Move假定相对于主Access窗口的坐标，或者更准确地说是自定义（不是该窗口的Windows定义的客户区域。另外，您的代码也对LongPtr：

有点困惑

Windows API中充满了指针（指针是对事物本身的简单引用）和“句柄”（它们只是不透明的指针）。当针对Win32时，指针值为32位宽;编译Win64时，64位宽。传统上，VBA没有指针类型，这迫使人们将指针和句柄硬编码为Long值，即32位整数。但是，Office 2010最终引入了LongPtr（为什么不Pointer我不知道！），它应该用于声明指针和句柄，因为它映射到64位LongLong在64位版本的Office中。
不幸的是，typedefs / type别名是而不是添加的，所以即使在最新版本的VBA中，你也不能只声明各种API类型并拥有（比方说）{{1像C，C ++或Delphi中那样显示为HDC类型的参数。
要记住的另一件事是，在定位Win64时，并非每个针对Win32的32位宽的API类型都会变为64位宽。特别是，HDC类型保持32位长，以及C / C ++ BOOL。
不重要，因为无论如何都包含了它，但int语句中的PtrSafe属性只是告诉Office您知道自己在做什么并且可以确认{{{ 1}}语句是64位兼容的。

就个人而言，我会像下面那样清理你的API声明 - 你的（不一致的）重命名标识符有点无意义，偶尔你错误地使用Declare来表示非指针或句柄的值，偶尔你在应使用Declare时错误地使用LongPtr：

Long

现在我们得到正确的代码;我建议这样的事情：

LongPtr

棘手的是弄清楚传递给Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _ ByRef lpPoint As POINT) As Long ' returns a BOOL Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _ ByVal hWnd As LongPtr, ByRef lpRect As RECT) As Long ' returns a BOOL Private Declare PtrSafe Function GetDC Lib "user32" ( _ ByVal hWnd As LongPtr) As LongPtr ' returns a HDC - Handle to a Device Context Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" ( _ ByVal hDC As LongPtr, ByVal nIndex As Long) As Long ' returns a C/C++ int Private Declare PtrSafe Function ReleaseDC Lib "user32" ( _ ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long ' also returns an int Private Const LOGPIXELSX = 88 ' sticking to the original names is less confusing IMO Private Const LOGPIXELSY = 90 ' ditto Private Const TwipsPerInch = 1440 Type POINT X As Long Y As Long End Type Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type的coords到底应该是什么样的 - 从API的角度来看，它不仅仅是Access窗口的'客户区'，所以我们必须弄清楚通过查看表单在Access'古怪的条款中的当前位置，并将其与API级别的位置进行比较。从这里我们得到一个我们在申请新职位时使用的偏移量。

要使用，Load事件处理程序只需要执行此操作：

Function PixelsToTwips(ByVal X As Long, ByVal Y As Long) As POINT
  Dim ScreenDC As LongPtr
  ScreenDC = GetDC(0)
  PixelsToTwips.X = X / GetDeviceCaps(ScreenDC, LOGPIXELSX) * TwipsPerInch
  PixelsToTwips.Y = Y / GetDeviceCaps(ScreenDC, LOGPIXELSY) * TwipsPerInch
  ReleaseDC 0, ScreenDC
End Function

Function TwipsToPixels(ByVal X As Long, ByVal Y As Long) As POINT
  Dim ScreenDC As LongPtr
  ScreenDC = GetDC(0)
  TwipsToPixels.X = X / TwipsPerInch * GetDeviceCaps(ScreenDC, LOGPIXELSX)
  TwipsToPixels.Y = Y / TwipsPerInch * GetDeviceCaps(ScreenDC, LOGPIXELSY)
  ReleaseDC 0, ScreenDC
End Function

Sub MoveFormToScreenPixelPos(Form As Access.Form, PixelX As Long, PixelY As Long)
  Dim FormWR As RECT, AccessWR As RECT, Offset As POINT, NewPos As POINT
  ' firstly need to calculate what the coords passed to Move are relative to
  GetWindowRect Application.hWndAccessApp, AccessWR
  GetWindowRect Form.hWnd, FormWR
  Offset = PixelsToTwips(FormWR.Left - AccessWR.Left, FormWR.Top - AccessWR.Top)
  Offset.X = Offset.X - Form.WindowLeft
  Offset.Y = Offset.Y - Form.WindowTop
  ' next convert our desired position to twips and set it
  NewPos = PixelsToTwips(PixelX - AccessWR.Left, PixelY - AccessWR.Top)
  Form.Move NewPos.X - Offset.X, NewPos.Y - Offset.Y
End Sub

Sub MoveFormToCursorPos(Form As Access.Form)
  Dim Pos As POINT
  GetCursorPos Pos
  MoveFormToScreenPixelPos Form, Pos.X, Pos.Y
End Sub

访问2010 VBA API TWIPS / PIXEL

1 个答案: