つらつら Excel VBA

私の備忘録です。

同心の円を連続作成

こんなの作りたい。アーチェリー!


円の中心位置と直径から図形のサイズを計算してオートシェイプを作成。

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

定数内容
0msoBringToFront最前面へ移動
1msoSendToBack最背面へ移動
2msoBringForward前面へ移動
3msoSendBackward背面へ移動
4msoBringInFrontOfText図形をテキストの前に移動(Word)
5msoSendBehindText図形をテキストの後ろに移動(Word)
以上。