访问2010 VBA API TWIPS / PIXEL

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

我必须承认，在涉及API编程时，我的编程技能必须投降，尤其是必须要花很长时间和longptr的时候。上面的代码是从不同的来源收集的。任何帮助是极大的赞赏

非常感谢

乔恩

Answer 1

位置计算不正确，因为您没有考虑到事实会GetCursorPos返回屏幕坐标，并Form.Move假设相对于主Access窗口或更确切地说是该窗口的自定义（非Windows定义）客户区域的坐标。另外，您的代码也对以下内容感到困惑LongPtr：

• Windows API充满了指针（指针是对事物的简单引用，而不是事物本身）和“句柄”（它们只是不透明的指针）。以Win32为目标时，指针值是32位宽。当为Win64编译时，为64位宽。传统上，VBA没有指针类型，这迫使人们对指针和Long值（即32位整数）进行硬编码。但是，Office 2010终于推出了LongPtr（为什么Pointer我不知道！），它应该用于声明指针和向前处理的句柄，因为它映射到LongLong64位版本的Office中的64位。

• 不幸的是，虽然没有添加typedefs / type别名，所以即使在最新版本的VBA中，您也不能只声明各种API类型，并且HDC不能HDC像在C，C ++或Delphi中那样显示（说）键入的参数。

• 要记住的另一件事是，并非所有针对Win32的API类型都是32位宽，而针对Win64则变为64位宽。特别是，该BOOL类型与C / C ++一起保持32位长int。

• 这并不重要，因为无论如何您都将其包括在内，但是语句中的PtrSafe属性Declare只是一个标记，用于告知Office您知道自己在做什么并且可以确认该Declare语句与64位兼容。

个人而言，我会清理你的API声明了类似下面的-你（不一致）的标识符的重命名是有点意义的，偶尔你错误地使用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

现在我们开始编写正确的代码；我建议这样的事情：

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

棘手的事情是弄清楚传递的坐标Move应该相对于什么-从API的角度来看，这不仅仅是Access窗口的“客户区”，因此我们必须通过查看表单的当前位置来弄清楚在Access的古怪背景中进行比较，并将其与其在API级别上的位置进行比较。由此得到一个偏移量，该偏移量将在应用新位置时使用。

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

Private Sub Form_Load()
  MoveFormToCursorPos Me
End Sub