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

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

感谢@Gacek 在 this question 中的回答为亮度函数。

Answer 1

我相信您最好的选择是使用 Left、Top、Width 和 Height 单元格属性。他们会以 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"