J. Garth的答案解释得很好，但正如我在评论中提到的，虽然它适用于此特定情况，但在其他情况下（例如缩放级别更改、目标范围在表格初始可见范围之外的拆分/冻结窗格），它会失败。更不用说它没有考虑标题行/列（也受缩放级别更改影响）以及在设置位置时包围表单的3D“边框/框架”。
我花了几天时间寻找一个完整的答案来覆盖所有可能性，而几乎在所有情况下都将表单的位置设置得非常接近正确位置的
唯一答案是由nerv编写的
这个，作为
这个讨论在MSDN论坛上的结果-很明显，大部分功劳归于他。我将其与其他来自各种其他来源的信息和代码“合并”以避免硬编码变量，使代码32位和64位兼容，并覆盖神秘的包围表单的3D框架问题。
表格代码
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
UserForm1.Show
End Sub
用户窗体代码
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
模块代码
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
以上大部分内容都不需要解释，它们都运作得非常完美 - 至少根据我所测试的。唯一仍然让我有点困扰的是，由于某种原因，表单框架在奇数行上（即它比所需单元格网线低1像素）并不完全符合要求，而在偶数行上则一切顺利。如果有人能找出原因，请与我分享这个谜团，因为我怀疑这不是一个简单的舍入问题...
编辑: 今天在使用计时器时，我想到了如何避免上面发生的奇偶行之间的差异：这只是一个声明点值和输出（以及缩放比例）As Double（即浮点数）而不是As Long（即整数）。这是我的愚蠢错误 - 我已经正确地编辑了代码来纠正它。我添加了一个verticaloffsetinpoints变量来调整那个奇怪的（但这次一致的）“比预期低1像素”的垂直故障，但我还没有找到解释。
