【发布时间】：2018-08-01 19:53:23
【问题描述】：
我有一个电子表格，其中涉及用户调整一些矩形形状的大小，这些矩形设置在 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 中对亮度函数的回答。
【问题讨论】：
-
我无法回答您的问题，但我确实注意到一件事可能会影响您的预期结果。您在 VBA 中使用 Round()，其功能与 Excel 中的 ROUND() 不同。你可以在这里找到更多信息Rounding in VBA
-
@pondersome 谢谢 - 我确实知道这一点；事实上，这并不重要，因为所有形状都与网格对齐。事实上，使用 string.format，它是完全多余的，我将删除 round()
标签： vba excel office365 shapes