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

Question

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

要重现错误，请右键单击 sheet 名称 > 查看代码 > 并将 VBA 代码粘贴到 sheet 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% 时，将在与活动单元格略有不同的位置创建矩形。 Excel每100行位置高度相差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

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

Excel Shape position disturbed by Windows Display Zoom settings

excel

vba

position

screen-resolution