时间戳

首页 > 解决方案 > 以列宽和行高 vba 显示 Excel 形状的尺寸

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

问题描述

我有一个电子表格，其中涉及用户调整一些矩形形状的大小，这些矩形设置在 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 在这个问题中对亮度函数的回答。

标签： vbaexceloffice365shapes

解决方案

我相信您最好的选择是使用 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"

推荐阅读