求教Excel Vba 画同心圆的问题

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参数。

Sub 宏1()

    Dim Sh As Shape

    Set Sh = ActiveSheet.Shapes.AddShape(msoShapeOval, 60, 60, 90, 90)

    Sh.Fill.ForeColor.RGB = RGB(255, 0, 0)

    Set Sh = Nothing

End Sub

把代码中的数字换成sheet2的单元格数据就可以了

---