Search code examples
excelvbapositionscreen-resolution

Excel Shape position disturbed by Windows Display Zoom settings

I would like to get accurate Shape position in Excel. I noticed that Shape.Top is being disturbed by Windows Display Zoom settings.

To reproduce the bug, please right click on a sheet name > View code > and paste the VBA code in the sheet VBA editor.

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

This code creates Rectange shape in the double clicked cell. Everything works fine as long as the display zoom of Windows settings is set up to 100%. However when we change display zoom in Windows settings to 125% then the rectangle is created in a slightly different place than the Active cell. There is a difference of 1 row in the location height for every 100 rows of Excel. So, when I click A100 cell then the Rectangle is created in A99 cell.

I would like to correct the location Rectangle creation so that Windows Zoom Display is taken into account.

Here is behavior with 100% Display Zoom:
enter image description here

Here is a buggy behavior I would like to fix which happens with 125% Display Zoom:
enter image description here

Here is the related inconspicuous challenge I threw on SO which might be a milestone in answering this question: Get Windows display zoom value

Solution

  • I cannot reproduce your issue. I'm working with 150% and positioning is correct in Excel even for the very last cells.

    Also there should be nothing need to be corrected.

    But there might be some issues with your code:

    • Avoid ThisWorkbook.ActiveSheet and use Target.Parent this is more reliable.
    • Also avoid using ActiveCell and use Target because ActiveCell might not have changed to the cell you clicked on yet. Target is the cell you doubleclicked not ActiveCell.

    Give the follwing a try. I doupt that the DPI is the issue and I suspect it is a ActiveCell related issue.

    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