寸法線の矢印を一括で変更するマクロ｜AutoCAD VBAマクロの作成方法

今回はAutoCADオープンチャットにて頂いたマクロの案をもとに作成したVBAマクロの解説です。
図面内に存在するすべての寸法の矢印の種類を一括で変換するというマクロです。
　

1. マクロ機能
2. サンプルコード
3. コード解説　
4. まとめ

マクロ機能

マクロの機能まとめ・アクティブな図面内のすべての寸法の矢印を一括で変更する　
・モデル空間、ペーパー空間、定義されているブロック内に存在するすべての寸法が対象
・寸法のうち両側に矢印がある寸法のみ対象 (※半径寸法や座標寸法などは対象外)
・コード内の引数の設定により変更する矢印の指定が可能
・コード内の引数の設定により変更前の矢印を指定することも可能
　(指定の矢印のみを別の矢印に一括で変更することが可能)

寸法オブジェクトには「長さ寸法」や「角度寸法」「半径寸法」などが存在しますが、本マクロではこれら寸法の種類は気にせず、両側に矢印がある寸法オブジェクトすべてを対象としています。指定の種類の寸法だけの矢印を変換したい場合はサンプルコードに対して条件の追加をしてください。
　

サンプルコード

マクロのサンプルコードは下記のとおりです。
コードを実行すると現在アクティブな図面内にあるすべての寸法の矢印を一括で変更します。

Option Explicit
'--------------------------------------------------------------------
'-  ﾒｲﾝ処理
'--------------------------------------------------------------------
Sub main()

    Dim cDims As Collection
    Dim oDim As AcadDimension
    
    'すべての寸法ｵﾌﾞｼﾞｪｸﾄ取得
    Set cDims = GetDimensions
    
    '寸法ｵﾌﾞｼﾞｪｸﾄﾙｰﾌﾟ
    For Each oDim In cDims
    
        '矢印変更
        Call ChangeArrowHead(oDim, acArrowSmall) 'acArrowSmall=小空白丸
    Next
    
    '再描画
    Call ThisDrawing.Regen(acAllViewports)

End Sub
'--------------------------------------------------------------------
'-  寸法ｵﾌﾞｼﾞｪｸﾄの矢印の種類を変更する
'-      oDim            ：対象寸法ｵﾌﾞｼﾞｪｸﾄ
'-      lArrowTypeAft   ：矢印の種類
'-      (lArrowTypeBef) ：変更する矢印の種類
'--------------------------------------------------------------------
Private Sub ChangeArrowHead(ByVal oDim As AcadDimension, _
                            ByVal lArrowTypeAft As AcDimArrowheadType, _
                            Optional ByVal lArrowTypeBef As AcDimArrowheadType = -1)

    Select Case TypeName(oDim)
    
    '矢印を2つ持つ寸法ｵﾌﾞｼﾞｪｸﾄ
    Case "IAcadDim3PointAngular", "IAcadDimAligned", "IAcadDimAngular", _
         "IAcadDimArcLength", "IAcadDimDiametric", "IAcadDimRotated"
    
        '強制的に矢印変更
        If lArrowTypeBef = -1 Then

            oDim.Arrowhead1Type = lArrowTypeAft
            oDim.Arrowhead2Type = lArrowTypeAft
        
        '現在の矢印と変更する矢印が一致している場合は変更
        Else
            If oDim.Arrowhead1Type = lArrowTypeBef Then
                oDim.Arrowhead1Type = lArrowTypeAft
            End If
            If oDim.Arrowhead2Type = lArrowTypeBef Then
                oDim.Arrowhead2Type = lArrowTypeAft
            End If
        End If

    '矢印を1つ持つ寸法ｵﾌﾞｼﾞｪｸﾄ
    'Case "IAcadDimRadial", "IAcadDimRadialLarge"

    '矢印を持たない寸法ｵﾌﾞｼﾞｪｸﾄ
    'Case "IAcadDimOrdinate"
 
    End Select
    
    Call oDim.Update

End Sub
'--------------------------------------------------------------------
'-  ThisDrawing内の全ての寸法ｵﾌﾞｼﾞｪｸﾄを取得する
'-      戻り値  ：寸法ｵﾌﾞｼﾞｪｸﾄが格納されたｺﾚｸｼｮﾝ
'--------------------------------------------------------------------
Private Function GetDimensions() As Collection

    Dim cDims As Collection
    Dim oDim As AcadDimension
    Dim oBlock As AcadBlock
    Dim oEntity As AcadEntity
    
    Set cDims = New Collection
    
    '全ﾌﾞﾛｯｸﾙｰﾌﾟ
    For Each oBlock In ThisDrawing.Blocks
        
        'ﾌﾞﾛｯｸ内要素ﾙｰﾌﾟ
        For Each oEntity In oBlock
        
            'AcadDimensionにｷｬｽﾄできる場合は寸法ｵﾌﾞｼﾞｪｸﾄ
            On Error Resume Next
            Set oDim = Nothing
            Set oDim = oEntity
            On Error GoTo 0
            
            '寸法ｵﾌﾞｼﾞｪｸﾄをｺﾚｸｼｮﾝに格納
            If Not oDim Is Nothing Then
                Call cDims.Add(oDim)
            End If
        Next
   Next
    
    Set GetDimensions = cDims

End Function

100

101

Option Explicit

'--------------------------------------------------------------------

'- ﾒｲﾝ処理

'--------------------------------------------------------------------

Sub main()

Dim cDims As Collection

Dim oDim As AcadDimension

'すべての寸法ｵﾌﾞｼﾞｪｸﾄ取得

Set cDims = GetDimensions

'寸法ｵﾌﾞｼﾞｪｸﾄﾙｰﾌﾟ

For Each oDim In cDims

'矢印変更

Call ChangeArrowHead(oDim, acArrowSmall) 'acArrowSmall=小空白丸

'再描画

Call ThisDrawing.Regen(acAllViewports)

End Sub

'--------------------------------------------------------------------

'- 寸法ｵﾌﾞｼﾞｪｸﾄの矢印の種類を変更する

'- oDim ：対象寸法ｵﾌﾞｼﾞｪｸﾄ

'- lArrowTypeAft ：矢印の種類

'- (lArrowTypeBef) ：変更する矢印の種類

'--------------------------------------------------------------------

Private Sub ChangeArrowHead(ByVal oDim As AcadDimension, _

ByVal lArrowTypeAft As AcDimArrowheadType, _

Optional ByVal lArrowTypeBef As AcDimArrowheadType = -1)

Select Case TypeName(oDim)

'矢印を2つ持つ寸法ｵﾌﾞｼﾞｪｸﾄ

Case "IAcadDim3PointAngular", "IAcadDimAligned", "IAcadDimAngular", _

"IAcadDimArcLength", "IAcadDimDiametric", "IAcadDimRotated"

'強制的に矢印変更

If lArrowTypeBef = -1 Then

oDim.Arrowhead1Type = lArrowTypeAft

oDim.Arrowhead2Type = lArrowTypeAft

'現在の矢印と変更する矢印が一致している場合は変更

Else

If oDim.Arrowhead1Type = lArrowTypeBef Then

oDim.Arrowhead1Type = lArrowTypeAft

End If

If oDim.Arrowhead2Type = lArrowTypeBef Then

oDim.Arrowhead2Type = lArrowTypeAft

End If

'矢印を1つ持つ寸法ｵﾌﾞｼﾞｪｸﾄ

'Case "IAcadDimRadial", "IAcadDimRadialLarge"

'矢印を持たない寸法ｵﾌﾞｼﾞｪｸﾄ

'Case "IAcadDimOrdinate"

End Select

Call oDim.Update

End Sub

'--------------------------------------------------------------------

'- ThisDrawing内の全ての寸法ｵﾌﾞｼﾞｪｸﾄを取得する

'- 戻り値：寸法ｵﾌﾞｼﾞｪｸﾄが格納されたｺﾚｸｼｮﾝ

'--------------------------------------------------------------------

Private Function GetDimensions() As Collection

Dim cDims As Collection

Dim oDim As AcadDimension

Dim oBlock As AcadBlock

Dim oEntity As AcadEntity

Set cDims = New Collection

'全ﾌﾞﾛｯｸﾙｰﾌﾟ

For Each oBlock In ThisDrawing.Blocks

'ﾌﾞﾛｯｸ内要素ﾙｰﾌﾟ

For Each oEntity In oBlock

'AcadDimensionにｷｬｽﾄできる場合は寸法ｵﾌﾞｼﾞｪｸﾄ

On Error Resume Next

Set oDim = Nothing

Set oDim = oEntity

On Error GoTo 0

'寸法ｵﾌﾞｼﾞｪｸﾄをｺﾚｸｼｮﾝに格納

If Not oDim Is Nothing Then

Call cDims.Add(oDim)

End If

Set GetDimensions = cDims

End Function

コード解説　

すべての寸法オブジェクト取得

寸法の矢印を変更するためにはまずモデル空間、ペーパー空間、ブロック内に存在するすべての寸法オブジェクトを取得します。モデル空間もペーパー空間はそれぞれModelSpaceとPaperSpaceとしてオブジェクトが用意されていますが、いずれもブロックと同じくBlockオブジェクトに属しています。

そのため、ThisDrawing内のすべてのブロックでループ処理を行えば、モデル空間もペーパー空間もブロックもすべてを網羅することができます。さらにそのブロック内のすべての要素でループを行うことで図面内の全ての要素をループすることができます。


    '全ﾌﾞﾛｯｸﾙｰﾌﾟ
    For Each oBlock In ThisDrawing.Blocks
        
        'ﾌﾞﾛｯｸ内要素ﾙｰﾌﾟ
        For Each oEntity In oBlock
            
            'oEntityに対する処理

        Next
   Next

'全ﾌﾞﾛｯｸﾙｰﾌﾟ

For Each oBlock In ThisDrawing.Blocks

'ﾌﾞﾛｯｸ内要素ﾙｰﾌﾟ

For Each oEntity In oBlock

'oEntityに対する処理

この全要素のループの中で寸法オブジェクトをすべて取得する必要がありますが、寸法オブジェクトには「Dim3PointAngular」「DimAligned」「DimAngular」「DimArcLength」「DimDiametric」「DimRotated」「DimRadial」「DimRadialLarge」「DimOrdinate」の9つのオブジェクトが用意されています。TypeName関数などを使って9つのオブジェクトのいずれかであれば寸法オブジェクトと判定するというコードでもよいですが、ここではAcadDimension型の変数に格納(キャスト)できれば寸法オブジェクトであると判定しています。(TypeName関数の判定は条件分岐文が長くなるため)

AcadDimensionは寸法オブジェクトの共通インタフェースであるため、これら9つの寸法オブジェクトはすべてAcadDimension型の変数に格納することができます。しかし、それ以外のオブジェクトは変数の型のタイプ不一致で格納することができません。この性質を利用して全要素のうち寸法オブジェクトのみを取得できるようにしています。最終的に「取得した寸法オブジェクトらは扱いやすいようコレクションに格納して返す」という1つの関数として定義しています。
　

寸法オブジェクトの矢印変更

コレクションとして取得した寸法オブジェクトに対して矢印の変更処理を行います。寸法オブジェクトのうち矢印を2つ持つオブジェクトは「Arrowhead1Typeプロパティ」「Arrowhead2Typeプロパティ」で、矢印を1つ持つオブジェクトは「ArrowheadTypeプロパティ」でそれぞれ変更可能です。

これらプロパティにはAcDimArrowheadType列挙型の値を入力します。AcDimArrowheadType列挙型はAutoCAD内に用意されている各矢印と紐づけられた整数値として定義されています。矢印を「小空白丸」にしたい場合は「acArrowSmall」、「塗り潰し四角」にしたい場合は「acArrowBoxFilled」というように変更したい矢印を表す列挙型の値を入力します。

サンプルコードでは前述の9つの寸法オブジェクトのうち矢印の数をもとに条件分岐を行い、矢印を2つ持つオブジェクトのみを変更の対象としています。
　

まとめ

今回は図面内に存在するすべての寸法の矢印の種類を一括で変換するマクロについての解説でした。
サンプルコードではコード内を直接書き換えることで矢印の種類を指定することができますが、誰かに使ってもらったり配布するというような場合は、UserFormなどを使って矢印の見た目を選択してもらうような仕様にしたほうがユーザーにやさしいツールとなります。

また、サンプルコードでは2つの矢印を持つ寸法オブジェクトを一括りとしていますが、例えば長さ寸法だけを対象にするというような条件を追加することもできます。寸法オブジェクトとしては9つの種類が用意されているので寸法の種類ごとに別の処理を行わせることも可能です。
　

メインページへ戻る