VBA技术：你需要知道的一些VBA操作形状的代码
VBA技术：你需要知道的一些VBA操作形状的代码
标签：VBA，Shape对象
本文介绍使用VBA创建和操控形状的知识。
在Excel中，可以通过功能区“插入”选项卡“插图”组中的“形状”库按钮在工作表中插入形状。可以使用形状来可视化数据、在形状中添加文本、作为执行宏代码的按钮，等等。
使用AddShape方法创建形状
要使用VBA在Excel中创建形状对象，必须调用AddShape方法。该方法有5个必需的参数：参数Type，想要生成的形状类型名；参数Left，放置到工作表中形状的左侧位置；参数Top，放置到工作表中形状的顶部位置；参数Width，形状的宽度；参数Height，形状的高度。
下面的VBA代码展示了如何创建2个形状并将它们存储在变量中以便后面引用。
Sub CreateShape()
Dim shp1 As Shape
Dim shp2 As Shape
Set shp1 = ActiveSheet.Shapes.AddShape( _
msoShape16pointStar, _
ActiveCell.Left, _
ActiveCell.Top, 80, 27)
Set shp2 = ActiveSheet.Shapes.AddShape( _
94, ActiveCell.Left, _
ActiveCell.Top, 80, 27)
End Sub选择形状类型
VBA可以使用大量的形状类型，如下图1-图10所示。
图1
图2
图3
图4
图5
图6
图7
图8
图9
图10
确定要创建的形状后，获取形状文本名称或枚举编号。将使用MSOAutoShapeType引用来编码所需的确切形状。
如果已经在电子表格中创建了形状，则可以使用下面的代码得到其枚举代码，以便在代码中引用。
Sub DetermineShapeType()
Dim ActiveShape As Shape
Dim UserSelection As Variant
Set UserSelection = ActiveWindow.Selection
On Error GoTo NoShapeSelected
Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
On Error Resume Next
MsgBox "所选形状类型:" & ActiveShape.AutoShapeType
Exit Sub
NoShapeSelected:
MsgBox "没有选择形状!"
End Sub确定形状位置
有两个属性可以修改，用以更改工作表中形状的位置。这两个属性是形状的Left和Top值，如下图11所示。
图11
如果不确定形状的大小，有两种常用的方法可以调整形状的大小。
方法1：基于工作表中某单元格左侧和顶部的位置。下面的代码显示了如何使用单元格B1的Left值和单元格B10的Top值来重新放置所创建的矩形。
Sub ShapePositionFromCell()
Dim shp As Shape
Set shp = ActiveSheet.Shapes.AddShape( _
msoShapeRectangle, _
Range("B1").Left, _
Range("B10").Top, _
100, 50)
End Sub方法2：可以在工作表中根据自己的喜好手动定位形状，并使用VBA读取左侧和顶部位置。下面的代码在消息框中显示了当前所选形状（ActiveShape）左侧和顶部的位置。
Sub DetermineShapePosition()
Dim ActiveShape As Shape
Dim UserSelection As Variant
Set UserSelection = ActiveWindow.Selection
On Error GoTo NoShapeSelected
Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
On Error Resume Next
MsgBox "左侧位置: " & ActiveShape.Left & vbNewLine & _
"顶部位置: " & ActiveShape.Top
Exit Sub
NoShapeSelected:
MsgBox "没有选择形状!"
End Sub确定形状大小
可以使用VBA修改两个属性来更改形状的大小。这两个属性是形状的Width值和Height值，如下图12所示。
图12
如果不确定形状的大小，有两种常用的方法可以调整形状的大小。
方法1：可以基于单元格区域的大小。
Sub ShapeSizeFromRange()
Dim shp As Shape
Dim rng As Range
Set rng = Range("A1:C4")
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
ActiveCell.Left, _
ActiveCell.Top, _
rng.Width, _
rng.Height)
End Sub方法2：可以手工按自己的意愿创建形状，然后使用VBA读取其宽度和高度。
Sub DetermineShapeSize()
Dim ActiveShape As Shape
Dim UserSelection As Variant
Set UserSelection = ActiveWindow.Selection
On Error GoTo NoShapeSelected
Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
On Error Resume Next
MsgBox "宽度: " & ActiveShape.Width & vbNewLine & _
"高度: " & ActiveShape.Height
Exit Sub
NoShapeSelected:
MsgBox "没有选择形状!"
End Sub格式化文本
代码如下：
Sub CreateShapeWithText()
Dim shp As Shape
Set shp = ActiveSheet.Shapes.AddShape( _
msoShape16pointStar, _
ActiveCell.Left, _
ActiveCell.Top, _
160, 60)
'在形状中添加文本
shp.TextFrame2.TextRange.Text = "完美Excel"
'加粗/斜体/下划线
With shp.TextFrame2.TextRange.Font
.Bold = True
.Italic = True
.UnderlineStyle = msoUnderlineDottedLine
'改变文本颜色
.Fill.ForeColor.RGB = RGB(225, 140, 71)
'改变文本大小
.Size = 14
End With
'居中对齐
shp.TextFrame.HorizontalAlignment = xlHAlignCenter
shp.TextFrame.VerticalAlignment = xlVAlignCenter
End Sub填充颜色和边框
代码如下：
Sub CreateShapeWithBorder()
Dim shp As Shape
Set shp = ActiveSheet.Shapes.AddShape( _
msoShapeRoundedRectangle, _
ActiveCell.Left, _
ActiveCell.Top, _
80, 27)
'填充颜色
shp.Fill.ForeColor.RGB = RGB(253, 234, 218)
'边框线条样式
shp.Line.DashStyle = msoLineDashDotDot
'边框颜色
shp.Line.ForeColor.RGB = RGB(252, 213, 181)
'调整边框宽度
shp.Line.Weight = 2
'删除边框
shp.Line.Visible = False
End Sub改变形状类型
如果要更改现有形状的类型，可以将AutoShapeType设置为不同的形状类型值。
Sub ChangeShapeType()
Dim shp As Shape
Set shp = ActiveSheet.Shapes("16-Point Star 6")
shp.AutoShapeType = msoShapeOval
End Sub使用VBA代码创建自己的宏按钮
下面的代码创建和格式化具有特定外观的形状。
Sub Create_Button()
Dim bttn As Shape
Set bttn = ActiveSheet.Shapes.AddShape( _
msoShapeRoundedRectangle, _
ActiveCell.Left, _
ActiveCell.Top, _
80, 27)
'修改文本格式
With bttn.TextFrame2.TextRange
.Text = "执行宏"
.Font.Bold = msoTrue
.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Font.Size = 14
End With
'居中对齐
bttn.TextFrame.HorizontalAlignment = xlHAlignCenter
bttn.TextFrame.VerticalAlignment = xlVAlignCenter
'填充颜色
bttn.Fill.ForeColor.RGB = RGB(217, 217, 217)
'无边框
bttn.Line.Visible = msoFalse
End Sub遍历所有特定类型的形状
如果需要工作表中特定形状类型，可以创建循环来测试AutoShapeType值以筛选结果。
下面的代码示例遍历当前选定的工作表中的所有形状对象，仅更改矩形形状的填充颜色。
Sub ChangeRectangleShapes()
Dim shp As Shape
'遍历当前工作表中所有形状
For Each shp In ActiveSheet.Shapes
'仅修改矩形形状
If shp.AutoShapeType = msoShapeRectangle Then
shp.Fill.ForeColor.RGB = RGB(253, 234, 218)
End If
Next shp
End Sub注：本文学习整理自thespreadsheetguru.com，供参考。
相关文章：VBA专题01：操作形状的VBA代码
腾讯云开发者
