将Excel工作表坐标转换为屏幕坐标

Question

给定Excel工作表上相对于工作表的形状的xy坐标，如何将它们转换为屏幕的xy坐标？

Answer 1

使用Window.RangeFromPoint方法。有关更多详细信息，请参见here。基本上这显示形状的xy坐标。您也可以使用Window.PointsToScreenPixelsX和Window.PointsToScreenPixelsY方法。

Answer 2

这激怒了我过去几天。我的解决方案使用ActiveWindow.RangeFromPoint方法在单元格中调入。 （编辑：我也包括一些代码为多监视器的情况。）

最后一部分通过modPixelsToPoints从点到像素进行正式转换。一个很好的解决方案，让您的用户窗体在相关单元上弹出。

这里是一个很大的F-U到Micros0ft，因为它首先不在Range对象中包含这样的函数/方法。

Function GetActiveCellXY() As POINTAPI 
     Dim target As POINTAPI 

     Dim startx As Single 
     Dim starty As Single 

     Dim currentx As Integer 
     Dim currenty As Integer 

     modMultiMonitor.Main 

     startx = modMultiMonitor.xStartingPoint 
     starty = modMultiMonitor.yStartingPoint 

    Restart: 

     If startx > 5000 Then ' If we hit this, we've missed the mark somehow 
      GetActiveCellXY.X = 0 
      GetActiveCellXY.Y = 0 
      Exit Function 
     End If 


     If Not ActiveWindow.RangeFromPoint(startx, starty) Is Nothing Then 
      currentx = ActiveWindow.RangeFromPoint(startx, starty).Column 
      currenty = ActiveWindow.RangeFromPoint(startx, starty).Row 
     Else 
      startx = startx + 10 
      starty = starty + 10 
      GoTo Restart 
     End If 

     If currentx < ActiveCell.Column Then 
      startx = startx + 5 
      GoTo Restart 
     End If 

     If currentx > ActiveCell.Column Then 
      startx = startx - 5 
      GoTo Restart 
     End If 

     If currenty < ActiveCell.Row Then 
      starty = starty + 5 
      GoTo Restart 
     End If 

     If currenty > ActiveCell.Row Then 
      starty = starty - 5 
      GoTo Restart 
     End If 



     'MsgBox startx & " " & starty 
     modPixelsToPoints.ConvertPixelsToPoints startx, starty 

     GetActiveCellXY.X = startx 
     GetActiveCellXY.Y = starty 
     Exit Function 

    HandleError:  ' Oh...I'll put in the On Error stuff someday 
      startx = startx + 10 
      starty = starty + 10 
      GoTo Restart 
    End Function 

还包括用于MultiMonitor确定的另一模块（modMultiMonitor）。我无法将下面的代码声称为我自己的代码。从https://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-msoffice_custom/detect-secondary-monitor-position/887b67de-8512-4883-81cb-52f9dea8226c?msgId=acf37bbe-a9b9-464c-b895-44a649aa602f明显被盗。

谢谢，谁写的！ :-D

Option Explicit 

    Public xStartingPoint As Long 
    Public yStartingPoint As Long 

    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (_ 
     ByVal lpClassName As String, ByVal lpWindowName As String) As Long 
    Private Const MONITORINFOF_PRIMARY = &H1 
    Private Const MONITOR_DEFAULTTONEAREST = &H2 
    Private Const MONITOR_DEFAULTTONULL = &H0 
    Private Const MONITOR_DEFAULTTOPRIMARY = &H1 
    Private Type RECT 
     Left As Long 
     Top As Long 
     Right As Long 
     Bottom As Long 
    End Type 
    Private Type MONITORINFO 
     cbSize As Long 
     rcMonitor As RECT 
     rcWork As RECT 
     dwFlags As Long 
    End Type 
    Private Type POINT 
     x As Long 
     y As Long 
    End Type 
    Private Declare Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (_ 
     ByVal hMonitor As Long, ByRef lpmi As MONITORINFO) As Long 
    Private Declare Function MonitorFromPoint Lib "user32.dll" (_ 
     ByVal x As Long, ByVal y As Long, ByVal dwFlags As Long) As Long 
    Private Declare Function MonitorFromRect Lib "user32.dll" (_ 
     ByRef lprc As RECT, ByVal dwFlags As Long) As Long 
    Private Declare Function MonitorFromWindow Lib "user32.dll" (_ 
     ByVal hWnd As Long, ByVal dwFlags As Long) As Long 
    Private Declare Function EnumDisplayMonitors Lib "user32.dll" (_ 
     ByVal hdc As Long, ByRef lprcClip As Any, ByVal lpfnEnum As Long, _ 
     ByVal dwData As Long) As Long 
    Private Declare Function GetWindowRect Lib "user32" (_ 
     ByVal hWnd As Long, lpRect As RECT) As Long 
    Dim hWnd As Long 
    Private Function MonitorEnumProc(ByVal hMonitor As Long, ByVal hdcMonitor As Long, _ 
     lprcMonitor As RECT, ByVal dwData As Long) As Long 
     Dim MI As MONITORINFO, R As RECT 
     Debug.Print "Moitor handle: " + CStr(hMonitor) 
     'initialize the MONITORINFO structure 
     MI.cbSize = Len(MI) 
     'Get the monitor information of the specified monitor 
     GetMonitorInfo hMonitor, MI 
     'write some information 
     Debug.Print "Monitor" & _ 
     " Left " & MI.rcMonitor.Left & _ 
     " Top " & MI.rcMonitor.Top & _ 
     " Size " & MI.rcMonitor.Right - MI.rcMonitor.Left & "x" & MI.rcMonitor.Bottom - MI _ 
     .rcMonitor.Top 
     Debug.Print "Primary monitor: " + CStr(CBool(MI.dwFlags = MONITORINFOF_PRIMARY)) 
     'check whether Form1 is located on this monitor 
     If MonitorFromWindow(hWnd, MONITOR_DEFAULTTONEAREST) = hMonitor Then 
     Debug.Print "hWnd is located on this monitor" 
     xStartingPoint = MI.rcMonitor.Left 
     yStartingPoint = MI.rcMonitor.Top 
     End If 
     'heck whether the point (0, 0) lies within the bounds of this monitor 
     If MonitorFromPoint(0, 0, MONITOR_DEFAULTTONEAREST) = hMonitor Then 
     Debug.Print "The point (0, 0) lies wihthin the range of this monitor..." 
     End If 
     'check whether Form1 is located on this monitor 
     GetWindowRect hWnd, R 
     If MonitorFromRect(R, MONITOR_DEFAULTTONEAREST) = hMonitor Then 
     Debug.Print "The rectangle of hWnd lies within this monitor" 
     End If 
     Debug.Print "" 
     'Continue enumeration 
     MonitorEnumProc = 1 
    End Function 
    Sub Main() 
     hWnd = FindWindow("XLMAIN", Application.Caption) 
     'start the enumeration 
     EnumDisplayMonitors ByVal 0&, ByVal 0&, AddressOf MonitorEnumProc, ByVal 0& 
    End Sub 

而这是modPixelsToPoints。再次，代码被盗http://officeoneonline.com/vba/positioning_using_pixels.html

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 

    Const LOGPIXELSX = 88 
    Const LOGPIXELSY = 90 
    Const TWIPSPERINCH = 1440 

    Private Declare Function GetSystemMetrics Lib "user32" (_ 
     ByVal nIndex As Long) As Long 

    Private Const SM_CXFULLSCREEN = 16 
    Private Const SM_CYFULLSCREEN = 17 

    Sub ConvertPixelsToPoints(ByRef X As Single, ByRef Y As Single) 
     Dim hDC As Long 
     Dim RetVal As Long 
     Dim XPixelsPerInch As Long 
     Dim YPixelsPerInch As Long 

     hDC = GetDC(0) 
     XPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSX) 
     YPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSY) 
     RetVal = ReleaseDC(0, hDC) 
     X = X * TWIPSPERINCH/20/XPixelsPerInch 
     Y = Y * TWIPSPERINCH/20/YPixelsPerInch 
    End Sub 

    Sub Test() 
     Dim Wt As Single 
     Dim Ht As Single 

     Wt = GetSystemMetrics(SM_CXFULLSCREEN) 
     Ht = GetSystemMetrics(SM_CYFULLSCREEN) 
     With f_ListSearch 
      ConvertPixelsToPoints Wt, Ht 
      .Left = Wt - .Width 
      .Show vbModeless 
     End With 
    End Sub