求教Excel Vba 画同心圆的问题

发布网友发布时间：2022-04-29 20:44

共1个回答

热心网友时间：2022-04-22 03:28

Excel的Shape.ScaleWidth和 Shape.ScaleHeight方法虽然有个msoScaleFromMiddle参数，但是实际上并没法从圆心开始放大，因此你干脆就在原来圆的基础上重心画圆。
下列代码只是在你代码的基础上修改的，主要只是如何确定其它圆左上角的位置。但一次只能画一个圆。如果你需要很多这样的同心圆，则需要你修改一下代码，将新的放大比率赋值给数组变量，然后用一个简单的循环去读取数组。

Sub txy()
Const r1 = 25
Const startpos = 10

Dim r2 As Single
Dim ratio As Single

Set myShe = Application.ActiveSheet '设置对象变量
'Set myJh = New Collection '设置新集合变量
myleft = Application.ActiveCell.Left + startpos '获得激活单元格的左边距
mytop = Application.ActiveCell.Top + startpos '获得激活单元格的上边距
With myShe.Shapes.AddShape(msoShapeOval, myleft, mytop, r1 * 2, r1 * 2) '添加园 msoShapeOval椭圆形
.Fill.Transparency = 1 '设置形状为透明
.Line.Weight = myXt + 0.75 '设置线条宽度
.Line.ForeColor.RGB = myRGB '设置前景色
End With

ratio = 0.8 '设置放大比例
r2 = r1 * ratio

myleft = Application.ActiveCell.Left - (r2 - (startpos + r1)) '获得激活单元格的左边距
mytop = Application.ActiveCell.Top - (r2 - (startpos + r1)) '获得激活单元格的上边距

With myShe.Shapes.AddShape(msoShapeOval, myleft, mytop, r2 * 2, r2 * 2) '添加园 msoShapeOval椭圆形
.Fill.Transparency = 1 '设置形状为透明
.Line.Weight = myXt + 0.75 '设置线条宽度
.Line.ForeColor.RGB = RGB(255, 0, 0) '设置前景色，如果完全复制可以设回原来的myRGB
End With

End Sub

myleft, mytop是圆的左上点，确切地说，是圆的外切正方形的左上角点的坐标位置，以磅为单位；50，50是圆的直径，实际上excel里面没有单独的画圆命令，这个命令是用来画椭圆的，两个参数分别为宽度和高度，相等的话就是画圆，不等就是椭圆。使用AddShape方法添加的图形，都具有五个参数，画什么形状主要取决于第一个type参数。