Excel形状位置受到Windows显示缩放设置的干扰

Question

我想在Excel中获得准确的Shape位置。我注意到Shape.Top受到Windows显示缩放设置的干扰。

要重现该错误，请右键单击工作表名称>查看代码>并将VBA代码粘贴到工作表VBA编辑器中。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
    On Error Resume Next
    ThisWorkbook.ActiveSheet.Shapes("BlueRectangle").Delete

    Dim sh As Object
    Set sh = ThisWorkbook.ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, ActiveCell.Width, ActiveCell.Height)
    sh.Name = "BlueRectangle"
End Sub

此代码在双击的单元格中创建矩形形状。只要将Windows设置的显示缩放比例设置为100％，一切都可以正常工作。但是，当我们将Windows设置中的显示缩放比例更改为125％时，将在与活动单元格稍有不同的位置创建矩形。每100行Excel的位置高度相差1行。因此，当我单击 A100 单元格时，将在 A99 单元格中创建矩形。

我想更正矩形创建的位置，以便考虑Windows缩放显示。

这是100％显示缩放的行为：

这是我要解决的错误行为，该错误会在125％的显示缩放下发生：

这是我向SO提出的不显眼的挑战，这可能是回答此问题的里程碑： Get Windows display zoom value

Answer 1

我无法复制您的问题。我正在使用150％，即使在最后一个单元格中，Excel中的定位也是正确的。

此外，也无需纠正任何内容。

但是您的代码可能存在一些问题：

• 避免使用ThisWorkbook.ActiveSheet，而使用Target.Parent会更可靠。
• 也请避免使用ActiveCell并使用Target，因为ActiveCell可能尚未更改为您单击的单元格。 Target是您双击而不是 ActiveCell的单元格。

请尝试一下。我怀疑DPI是问题，我怀疑这是ActiveCell相关问题。

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True

    On Error Resume Next
    Target.Parent.Shapes("BlueRectangle").Delete
    On Error GoTo 0 'always re-activate error handling after an expected error

    Dim shp As Shape
    Set shp = Target.Parent.Shapes.AddShape(msoShapeRectangle, Target.Left, Target.Top, Target.Width, Target.Height)
    shp.Name = "BlueRectangle"
End Sub