以列宽和行高vba显示Excel形状的尺寸

Question

我有一个电子表格，其中涉及用户调整一些矩形形状的大小，这些形状设置在Excel网格的背景上，列宽=行高= 10像素。此背景的目的是给计划定一个比例，该比例由形状决定；在这种情况下，一列或一行代表10厘米-每10个单元格之后就有一个粗边框代表米：

当用户调整矩形的大小时，我希望矩形内的文本根据计划的比例显示尺寸。我已经阅读了许多有关如何以点为单位提供形状尺寸，以像素为单位提供列和行（或基于字体的单位）的文章，并且发现了它们之间的转换功能，但似乎没有给出结果我希望-宽度和高度的值取决于缩放级别，即使显示的像素宽度保持不变，缩小时也会得到越来越小的结果。

有没有一种方法可以将网格的像素单位一致地转换为形状的点单位，这样我就可以实质上算出构成形状尺寸的列宽和行高是多少？这是我到目前为止编写的宏：

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

******出于完整性考虑，这是我在以下答案中为实现该解决方案而编写的最终脚本******

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

感谢this question中有关亮度功能的@Gacek答案。

Answer 1

我相信您最好的选择是利用“左”，“上”，“宽度”和“高度”单元格的属性。它们会以Excel奇怪的格式（与形状使用的单位相同）告诉您值，因此您无需进行任何转换。

不利的一面是，据我所知，没有办法获取给定的上/左值处存在的行/列，因此您需要搜索所有行/列，直到找到符合您形状的边界。

这是一个简单的示例（这里某处可能是一个错误的错误）

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"