AutoCAD VBA：属性値（整数）を順に採番するブロック参照の挿入/配置済ブロック参照属性の変更

[#1]

Issue

バルーン番号の番号部分を属性定義（タグ名 Index）したブロック定義（ブロック名 My Block）があります。

このブロック定義の挿入時にバルーン番号を加算しながら重複のないバルーン番号を持つブロック参照を配置することは可能でしょうか？

Solution

新たな My Block ブロック参照の挿入時に、モデル空間に配置されたすべての My Block を走査して Index タグ名を持つ属性値（文字列）を取得、最大値となり値をバルーン番号に設定することで実現することが出来るはずです。

次のサンプルは、My Block ブロック定義後に同処理を実装する VBA マクロの例です。属性値の妥当性チェックの処理はしていませんが、インデックス番号を保持するタグ名 Index を持つ属性には、半角整数の文字列が設定されているものとしています。IndexOnBlockRef プロシージャを実行してみてください。

' 挿入時に属性値（インデックス番号）を順番に割り当てるメイン プロシージャ
Public Sub IndexOnBlockRef()
    Dim strBlkName
    strBlkName = "MyBlock"
    CreateBlockDef (strBlkName)
    
    Dim insPt(0 To 2) As Double
    insPt(0) = 0: insPt(1) = 0: insPt(2) = 0
 
    Dim retPt As Variant
    Dim index As Integer
    Dim blockRefObj As AcadBlockReference
    On Error Resume Next
    Do
        Err.Clear
        retPt = ThisDrawing.Utility.GetPoint(, vbCrLf & "ブロックの挿入点を指示 : ")
        If Err Then
            Exit Do
        End If
        Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(retPt, strBlkName, 1#, 1#, 1#, 0)
        index = FindMaxIndexAttribute()
        Call SetIndexAttribute(blockRefObj, index + 1)
    Loop
End Sub

' 属性定義（タグ名 Index）を含むブロック定義 My Block を定義する関数
Public Function CreateBlockDef(strBlkName As String)
    Dim blockObj As AcadBlock
    Dim insPt(0 To 2) As Double
    insPt(0) = 0: insPt(1) = 0: insPt(2) = 0
    On Error Resume Next
    Set blockObj = ThisDrawing.Blocks.Item(strBlkName)
    If Err Then
        Set blockObj = ThisDrawing.Blocks.Add(insPt, strBlkName)
        
        Dim circleObj As AcadCircle
        Set circleObj = blockObj.AddCircle(insPt, 100#)
 
        Dim attributeObj As AcadAttribute
        Set attributeObj = blockObj.AddAttribute(100#, acAttributeModePreset, "インデックス？", insPt, "Index", "0")
        attributeObj.Alignment = acAlignmentMiddleCenter
    End If
End Function

' 与えられたブロック参照のタグ名 Index の属性値（整数）を返す関数
Public Function GetIndexAttribute(blockRefObj) As Integer
    Dim varAttributes As Variant
    varAttributes = blockRefObj.GetAttributes

    Dim strAttribute As String
    strAttribute = "-1"
    For Each blockAttr In varAttributes
        If blockAttr.TagString = "Index" Then
            strAttribute = blockAttr.TextString
            Exit For
        End If
    Next
    GetIndexAttribute = CInt(strAttribute)
End Function

' モデル空間に配置されたすべての My Block ブロック参照を走査して割り当てられた最大の Index の属性値（整数）を返す関数う
Public Function FindMaxIndexAttribute() As Integer
    Dim sset As AcadSelectionSet
    On Error Resume Next
    Set sset = ThisDrawing.SelectionSets.Item("ssblocks")
    If Not Err Then
        sset.Delete
    End If
    Set sset = ThisDrawing.SelectionSets.Add("ssblocks")
      
    Dim FilterType(1) As Integer
    Dim FilterData(1) As Variant
    FilterType(0) = 0
    FilterData(0) = "Insert"
    FilterType(1) = 2
    FilterData(1) = "MyBlock"
    sset.Select acSelectionSetAll, , , FilterType, FilterData
    
    Dim index As Integer
    index = -1
    
    Dim maxIndex As Integer
    maxIndex = -1
    
    If sset.Count > 0 Then
        Dim entityObj As AcadEntity
        For Each entityObj In sset
            Dim blockRefObj As AcadBlockReference
            Set blockRefObj = entityObj
            index = GetIndexAttribute(blockRefObj)
            If maxIndex < index Then
                maxIndex = index
            End If
        Next
    End If
    
    FindMaxIndexAttribute = maxIndex
End Function

' 与えられたブロック参照1のタグ名 Index の属性値（整数）を設定する関数
Public Function SetIndexAttribute(blockRefObj, index)
    Dim varAttributes As Variant
    varAttributes = blockRefObj.GetAttributes
    For Each blockAttr In varAttributes
        If blockAttr.TagString = "Index" Then
            blockAttr.TextString = CStr(index)
            Exit For
        End If
    Next
End Function

既に挿入配置済のブロック参照 My Block に新たにインデクス番号の属性値を割り当てる場合には、前述のコードに次の AssignIndexToBlockRef プロシージャを追加・実行することでブロック参照を順に選択して値を更新することも出来ます。

' 配置済のブロック参照に指定値から属性値（インデックス番号）を順番に割り当てるメイン プロシージャ
Public Sub AssignIndexToBlockRef()
    Dim strBlkName
    strBlkName = "MyBlock"
    
    Dim startIndex As Integer
    startIndex = FindMaxIndexAttribute()
    
    On Error Resume Next
    Err.Clear
        
    Dim returnInt As Integer
    ThisDrawing.Utility.InitializeUserInput (4) ' disallow negative
    returnInt = ThisDrawing.Utility.GetInteger(vbCrLf & "割り当てるインデクス開始値を入力<" & CStr(startIndex + 1) & "> : ")
    If Err = 0 Then
        If returnInt <= startIndex Then
            MsgBox ("指定した値と同じ、または、大きいインデックス値を持つブロック参照が既に存在します" & vbCrLf & _
            "既に配置済のブロック参照とインデックス値が重複してしまう可能性があります")
            Exit Sub
        End If
        startIndex = returnInt - 1
    End If
    
    Dim returnObj As AcadObject
    Dim basePnt As Variant
    Do
        Err.Clear
        ThisDrawing.Utility.GetEntity returnObj, basePnt, "ブロック参照を選択:"
        If Err = 0 Then
            If returnObj.EntityName = "AcDbBlockReference" Then
                Dim blockRefObj As AcadBlockReference
                Set blockRefObj = returnObj
                If blockRefObj.Name = strBlkName Then
                    startIndex = startIndex + 1
                    Call SetIndexAttribute(blockRefObj, startIndex)
                End If
            End If
        Else
            Exit Do
        End If
    Loop
End Sub