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

我想在Excel中获得准确的形状位置。我注意到，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%显示缩放的行为：

下面是我想修复的一个bug行为，它发生在125%显示缩放时：

下面是我提出的一个相关的不显眼的挑战，这可能是回答这个问题的一个里程碑：

---

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

也应该没有什么需要纠正的

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

• 避免使用

  thishworkbook.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

---

这会有助于获得成功吗？还是会抛出相同的错误地址？@JvdV您建议的解决方案返回的结果比上面介绍的错误更不准确。不管怎样，谢谢。佩赫，把我的帽子摘下来。您找到了原因。@PrzemyslawRemin因为这解决了您的问题，我能想到的唯一解释是：将DPI更改为100%以外的值可能会大大降低计算机的速度，因此如果您在双击之前双击一个单元格触发

工作表，\u双击

比Excel更改

ActiveCell

到您双击的单元格。•所以这只是另一个例子，为什么你应该总是避免

ActiveCell

。