'Esto en un módulo
Option Explicit
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Public Type pointcoordinatestype
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private pixelsperinchx As Long, pixelsperinchy As Long, pointsperinch As Long, zoomratio As Double
#If VBA7 And Win64 Then
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
#Else
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) 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
#End If
Private Sub ConvertUnits()
Dim hdc As LongPtr
hdc = GetDC(0)
pixelsperinchx = GetDeviceCaps(hdc, LOGPIXELSX) ' Usually 96
pixelsperinchy = GetDeviceCaps(hdc, LOGPIXELSY) ' Usually 96
ReleaseDC 0, hdc
pointsperinch = Application.InchesToPoints(1) ' Usually 72
zoomratio = ActiveWindow.Zoom / 100
End Sub
Private Function PixelsToPointsX(ByVal pixels As Long) As Double
PixelsToPointsX = pixels / pixelsperinchx * pointsperinch
End Function
Private Function PixelsToPointsY(ByVal pixels As Long) As Double
PixelsToPointsY = pixels / pixelsperinchy * pointsperinch
End Function
Private Function PointsToPixelsX(ByVal points As Double) As Long
PointsToPixelsX = points / pointsperinch * pixelsperinchx
End Function
Private Function PointsToPixelsY(ByVal points As Double) As Long
PointsToPixelsY = points / pointsperinch * pixelsperinchy
End Function
Public Sub GetPointCoordinates(ByVal cellrange As Range, ByRef pointcoordinates As pointcoordinatestype)
Dim i As Long
ConvertUnits
Set cellrange = cellrange.MergeArea
For i = 1 To ActiveWindow.Panes.Count
If Not Intersect(cellrange, ActiveWindow.Panes(i).VisibleRange) Is Nothing Then
pointcoordinates.Left = PixelsToPointsX(ActiveWindow.Panes(i).PointsToScreenPixelsX(cellrange.Left))
pointcoordinates.Top = PixelsToPointsY(ActiveWindow.Panes(i).PointsToScreenPixelsY(cellrange.Top))
pointcoordinates.Right = pointcoordinates.Left + cellrange.Width * zoomratio
pointcoordinates.Bottom = pointcoordinates.Top + cellrange.Height * zoomratio
Exit Sub
End If
Next
End Sub
'Y esto en el formulario
Private Sub UserForm_Initialize()
Dim pointcoordinates As pointcoordinatestype, horizontaloffsetinpoints As Double, verticaloffsetinpoints As Double
With Me
horizontaloffsetinpoints = (.Width - .InsideWidth) / 2
verticaloffsetinpoints = 1
Call GetPointCoordinates(ActiveCell, pointcoordinates)
.StartUpPosition = 0
.Top = pointcoordinates.Top - verticaloffsetinpoints
.Left = pointcoordinates.Left - horizontaloffsetinpoints
End With
End Sub