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

时间:2013-08-07 19:10:30

标签: excel-vba vba excel

给定Excel工作表上与工作表相关的形状的xy坐标,如何将它们转换为屏幕的xy坐标?

2 个答案:

答案 0 :(得分:0)

使用Window.RangeFromPoint方法。有关详细信息,请参阅here。基本上,这显示了形状的xy坐标。您也可以使用Window.PointsToScreenPixelsXWindow.PointsToScreenPixelsY方法。

答案 1 :(得分:0)

过去几天这激怒了我。我的解决方案使用ActiveWindow.RangeFromPoint方法将单元格置于单元格中。 (编辑:我还包括一些用于多监视器情况的代码。)

最后一部分通过modPixelsToPoints进行从点到像素的正式转换。一个很好的解决方案,让你的UserForm弹出相关单元格。

这是一个很大的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