Show dimensions of Excel shape in column widths and row heights vba

Question

I have a spreadsheet that involves the user resizing some rectangular shapes, which are set on a background of an Excel grid with column width = row height = 10pixels. The purpose of this background is to give a scale to the plan, which is made by the shapes; in this case, one column or row represents 10cm - there is a thick border after every 10 cells to represent a metre:

When the user resizes the rectangle, I would like the text inside the rectangle to display the dimensions, according to the scale of the plan. I have read many articles about how the shapes dimensions are provided in points, and the columns and rows in pixels (or a unit based on the font), and have found the conversion function between them, but it does not seem to give the results I would expect - the values for the width and height depend on the level of zoom, giving smaller and smaller results as I zoom out, even though the displayed pixel width remains the same.

Is there a way to consistently convert the pixel units of the grid to the points unit of the shapes such that I can essentially count how many column widths and row heights comprise the shape dimensions? Here is the macro I have written so far:

Option Explicit
Dim sh As Shape
Dim dbPx_Per_Unit As Double
Dim strUnit As String
Dim UserSelection As Variant
Dim strText As String
Dim strWidth As String
Dim strHeight As String
Sub LabelShapeSize()
Set UserSelection = ActiveWindow.Selection

'is selection a shape?
  On Error GoTo NoShapeSelected
    Set sh = ActiveSheet.Shapes(UserSelection.Name)
  On Error Resume Next

'pixels are the units for the columns and rows
'dbPx_Per_Unit = InputBox("there are this many pixels per unit:", "Conversion Rate", 10)
dbPx_Per_Unit = 100

'strUnit = InputBox("Unit Name:", "Units", "M")
strUnit = "M"

With sh
    'Width and length is measured in points, so we need to convert the points to pixels to get the actual size
    strWidth = Format(Application.ActiveWindow.PointsToScreenPixelsX(.Width) / dbPx_Per_Unit, "#,##0.0")
    strHeight = Format(Application.ActiveWindow.PointsToScreenPixelsY(.Height) / dbPx_Per_Unit, "#,##0.0")

    'this is our message that will be in the shape
    strText = strWidth & strUnit & " x " & strHeight & strUnit

    With .TextFrame2
        .VerticalAnchor = msoAnchorMiddle

        With .TextRange.Characters
            .ParagraphFormat.FirstLineIndent = 0
            .ParagraphFormat.Alignment = msoAlignCenter
            .Text = strText

            'I'll sort something out for dark shapes at some point, but for now let's just write in black ink
            With .Font
                .Fill.Visible = msoTrue
                .Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
                .Fill.Solid
                .Size = 10
            End With
        End With
    End With
End With

Exit Sub

'No shape error
NoShapeSelected:
  MsgBox "You must select a shape to calculate dimensions!", vbCritical, "Object not set to an instance of a Nobject"

End Sub

****** for completeness, here is the final script I wrote implementing the solution in the answer below ******

Option Explicit
Dim sh As Shape
Dim db_Cols_Per_Unit As Double
Dim strUnit As String
Dim strText As String
Dim userSelection As Variant
Dim ws As Worksheet
Dim clrBackground As Long

Dim leftCol As Integer
Dim colWidth As Integer

Dim topRow As Integer
Dim rowHeight As Integer

Sub LabelShapeSize()
Set userSelection = ActiveWindow.Selection
Set ws = ActiveSheet
db_Cols_Per_Unit = 10
strUnit = "M"

'is selection a shape?
  On Error GoTo NoShapeSelected

    Set sh = ActiveSheet.Shapes(userSelection.Name)
    On Error Resume Next

    topRow = 1
    rowHeight = 0
    leftCol = 1
    colWidth = 0

    With sh
        While ws.Cells(1, leftCol).Left <= .Left 'Move left until we find the first column the shape lies within
            leftCol = leftCol + 1
        Wend

        While ws.Cells(1, leftCol + colWidth).Left <= .Left + .Width 'Continue moving left until we find the first column the shape does not lie within
            colWidth = colWidth + 1
        Wend

        While ws.Cells(topRow, 1).Top <= .Top 'Move down until we find the first row the shape lies within
            topRow = topRow + 1
        Wend

        While ws.Cells(topRow + rowHeight, 1).Top <= .Top + .Height 'Continue moving down until we find the first row the shape does not lie within
            rowHeight = rowHeight + 1
        Wend

        'this is our message that will be in the shape
        strText = Format(colWidth / db_Cols_Per_Unit & strUnit, "#,##0.0") & " x " & rowHeight / Format(db_Cols_Per_Unit, "#,##0.0") & strUnit

        clrBackground = .Fill.ForeColor.RGB

        With .TextFrame2
            .VerticalAnchor = msoAnchorMiddle

            With .TextRange.Characters
                .ParagraphFormat.FirstLineIndent = 0
                .ParagraphFormat.Alignment = msoAlignCenter
                .Text = strText

                With .Font
                    .Fill.Visible = msoTrue
                    .Fill.ForeColor.RGB = ContrastColor(clrBackground)
                    .Fill.Solid
                    .Size = 10
                End With
            End With
        End With
    End With
Exit Sub

'No shape error
NoShapeSelected:
  MsgBox "You must select a shape to calculate dimensions!", vbCritical, "Object not set to an instance of a Nobject"

End Sub

Function ContrastColor(clrBackground As Long) As Long
Dim brightness As Integer
Dim luminance As Double
Dim r As Integer
Dim g As Integer
Dim b As Integer

r = clrBackground Mod 256
g = (clrBackground \ 256) Mod 256
b = (clrBackground \ 65536) Mod 256

luminance = ((0.199 * r) + (0.587 * g) + (0.114 * b)) / 255

If luminance > 0.5 Then
    brightness = 0
Else
    brightness = 255
End If

ContrastColor = RGB(brightness, brightness, brightness)

End Function

thanks to @Gacek answer in this question for the luminance function.

Answer 1

I believe your best bet would be to make use of the Left, Top, Width, and Height cell properties. They'll tell you the value in Excel's weird format (the same units as used by the shapes), so you won't need to do any conversions.

The downside is that as far as I know of, there's no way to get the row/column that exists at a given top/left value, so you need to search through all the rows/columns until you find the one that matches your shape's boundaries.

Here's a quick example (there's probably an off-by-one error in here somewhere)

Dim UserSelection As Variant
Dim ws As Worksheet
Dim sh As Shape

Dim leftCol As Integer
Dim colWidth As Integer

Dim topRow As Integer
Dim rowHeight As Integer

Set ws = ActiveSheet
Set UserSelection = ActiveWindow.Selection

Set sh = ActiveSheet.Shapes(UserSelection.Name)

leftCol = 1
colWidth = 0

While ws.Cells(1, leftCol).Left <= sh.Left 'Move left until we find the first column the shape lies within
    leftCol = leftCol + 1
Wend

While ws.Cells(1, leftCol + colWidth).Left <= sh.Left + sh.width 'Continue moving left until we find the first column the shape does not lie within
    colWidth = colWidth + 1
Wend

topRow = 1
rowHeight = 0

While ws.Cells(topRow, 1).Top <= sh.Top 'Move down until we find the first row the shape lies within
    topRow = topRow + 1
Wend

While ws.Cells(topRow + rowHeight, 1).Top <= sh.Top + sh.height 'Continue moving down until we find the first row the shape does not lie within
    rowHeight = rowHeight + 1
Wend

MsgBox "Shape is " & colWidth & " columns wide by " & rowHeight & " rows high"