こんなの作りたい。アーチェリー!
円の中心位置と直径から図形のサイズを計算してオートシェイプを作成。
Sub テスト() Dim 中心点Left As Integer Dim 中心点Top As Integer 中心点Left = Range("E15").Left 中心点Top = Range("E15").Top Dim 直径 As Integer For 直径 = 60 To 300 Step 60 Call オートシェイプ楕円(中心点Left, 中心点Top, 直径) Next End Sub Sub オートシェイプ楕円(中心点Left, 中心点Top, 直径, _ Optional iLineColor As Long = rgbBlack, _ Optional iForeColor As Long = rgbWhite) Dim 開始位置Left As Integer Dim 開始位置Top As Integer 開始位置Left = 中心点Left - (直径 / 2) 開始位置Top = 中心点Top - (直径 / 2) Dim myShape As Shape Set myShape = Shapes.AddShape(msoShapeOval, 開始位置Left, 開始位置Top, 直径, 直径) myShape.Line.ForeColor.RGB = iLineColor '外枠 myShape.Fill.ForeColor.RGB = iForeColor '塗りつぶし色 'myShape.Fill.Visible = msoFalse '塗りつぶし無し Set myShape = Nothing End Sub
同心の円を小さい順に作ると、後に作られた円に隠れてしまう。大きい円から作ればいいのだが、せっかくなので順番を変える処理を作成。
作った円はグループ化。ついでにオートシェイプ全削除処理も作成。
Sub オートシェイプ順番変更() Dim myShape As Shape For Each myShape In Shapes myShape.ZOrder msoSendToBack '最背面へ移動 Next Set myShape = Nothing End Sub Sub オートシェイプグループ化() ActiveSheet.Shapes.SelectAll Selection.ShapeRange.Group.Name = "test" End Sub Sub オートシェイプ全削除() Dim myShape As Shape For Each myShape In Shapes myShape.Delete Next Set myShape = Nothing End Sub
以下、完成品。
オートシェイプ全削除と全グループ化が行われます。取扱注意。
Sub アーチェリー的() Call オートシェイプ全削除 Dim 中心点Left As Integer Dim 中心点Top As Integer 中心点Left = Range("E15").Left 中心点Top = Range("E15").Top Call オートシェイプ楕円(中心点Left, 中心点Top, 10, , rgbYellow) Call オートシェイプ楕円(中心点Left, 中心点Top, 20, , rgbYellow) Call オートシェイプ楕円(中心点Left, 中心点Top, 30, , rgbRed) Call オートシェイプ楕円(中心点Left, 中心点Top, 40, , rgbRed) Call オートシェイプ楕円(中心点Left, 中心点Top, 50, , rgbBlue) Call オートシェイプ楕円(中心点Left, 中心点Top, 60, , rgbBlue) Call オートシェイプ楕円(中心点Left, 中心点Top, 70, , rgbGray) Call オートシェイプ楕円(中心点Left, 中心点Top, 80, , rgbGray) Call オートシェイプ楕円(中心点Left, 中心点Top, 90) Call オートシェイプ楕円(中心点Left, 中心点Top, 100) Call オートシェイプ順番変更 Call オートシェイプグループ化 End Sub
オートシェイプの順番を変える ZOrder
値 | 定数 | 内容 |
---|---|---|
0 | msoBringToFront | 最前面へ移動 |
1 | msoSendToBack | 最背面へ移動 |
2 | msoBringForward | 前面へ移動 |
3 | msoSendBackward | 背面へ移動 |
4 | msoBringInFrontOfText | 図形をテキストの前に移動(Word) |
5 | msoSendBehindText | 図形をテキストの後ろに移動(Word) |