excelperfect
标签：VBA
这是在www.wimgielis.com中看到的一段代码，可以在工作表中自动添加一个矩形，用户可以指定矩形的大小和填充的颜色，以及指定相关联的宏。辑录于此，供参考。
VBA代码如下：
代码语言：javascript复制Sub Add_Macro_Rectangle()
Dim ws As Worksheet
Dim sh As Object
Dim sText As String
Dim sDimensions As String
Dim rDimensions As Range
Dim iColor As Integer
Dim s As String
On Error Resume Next
Set ws = ActiveSheet
sDimensions = Trim(Application.InputBox("请输入形状的大小 (行 x 列)", "形状大小", "3x3", , , , , 2))
iColor = Trim(Application.InputBox("请输入形状的颜色: 1 =蓝色, 2 =绿色, 3 =红色", "形状的填充颜色", "2", , , , , 1))
iColor = WorksheetFunction.Min(iColor, 3)
iColor = WorksheetFunction.Max(iColor, 0)
Set rDimensions = Selection.Cells(1).Resize(CDbl(Split(sDimensions, "x")(0)), CDbl(Split(sDimensions, "x")(1)))
With rDimensions
Set sh = ws.Shapes.AddShape(msoShapeRoundedRectangle, .Left, .Top, .Width, .Height)
End With
With sh
.Name = "Run_macro"
'水平居中
With .TextFrame2.TextRange.Characters(1, Len(sText)).ParagraphFormat
.FirstLineIndent = 0 '水平居中
.Alignment = msoAlignCenter
End With
'垂直居中
With .TextFrame2
.VerticalAnchor = msoAnchorMiddle '垂直居中
End With
With .Fill
.ForeColor.RGB = Choose(iColor, RGB(0, 176, 240), RGB(146, 208, 80), RGB(255, 0, 0))
.Transparency = 0
.Solid
End With
With .Line
.ForeColor.RGB = sh.Fill.ForeColor.RGB
.Transparency = sh.Fill.Transparency
End With
.Placement = xlMove 'xlMoveAndSize = 1, xlMove = 2, xlFreeFloating = 3
.Select
Application.Dialogs(xlDialogAssignToObject).Show
s = Split(.OnAction, "!")(1)
If Len(s) = 0 Then s = .OnAction
sText = Trim(Application.InputBox("请输入形状中的文本", "形状文本", s, , , , , 2))
If sText = "False" Or Len(sText) = 0 Then sText = "添加标题"
With .TextFrame.Characters
.Text = sText
.Font.Color = vbWhite
.Font.Bold = True
End With
rDimensions.Cells(1).Select
End With
On Error GoTo 0
Set ws = Nothing
End Sub欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。
