Jak editovat výzvy atributů v existujícím bloku?

Produkt: AutoCAD 2000i
Datum: 03.04.2001

Před vyřešením problému pomocí VBA (šel by samozřejmě vyřešit i jinak, např. příkazem REFEDIT), si alespon stručně shrneme známá fakta:

Výzva (prompt) je součástí definice atributu (objekt AcadAttribute)
Pro přístup k definici atributu použijeme definici blok (objekt AcadBlock)
K definici bloku přistupujeme pomocí kolekce AcadBlocks, která představuje tabulku bloků

Řešení problému by tedy mohlo být následující:

Uživatel vyberen referenici bloku ve výkrese
Z reference bloku zjistíme definici bloku
Pokud definice bloku bude obsahovat definici atributu, zeptáme se uživatele na novou výzvu

Pro výběr bloku použijeme metodu GetEntity objektu AcadUtility:

    ThisDrawing.Utility.GetEntity obj, pt, "Vyberte blok: "

Je dobré testovat, zda-li při výběru nedošlo k nějaké chybě. K tomu použijeme globální objekt Err a na začátku kódu použijeme výraz On Error Resume Next, který zajistí, že při výskytu chybu bude program pokračovat dál:

    On Error Resume Next
    ThisDrawing.Utility.GetEntity obj, pt, "Vyberte blok: "
    If Err <> 0 Then
        Exit Sub
    End If

Také bychom měli otestovat, zda-li uživatel skutečně vybral námi požadovanou entitu. Objekt AcadEntity obsahuje vlastnost ObjectName, pomocí pomocí které zjistíme název třídy objektu. Tento název třídy můžeme otestovat a tak zjistit, jakého typu je námi vybraná entita:

    If StrComp(ent.ObjectName, "AcDbBlockReference", vbTextCompare) <> 0 Then
        MsgBox "Vybraná entita není blok !"
        Exit Sub
    End If

Jak ale získat objekt typu AcadBlockReference, když metoda GetEntity vrací objekt typu AcadEntity? Jednoduše si pomůžeme přiřazením, neměli bychom však zapomenout otestovat, zda-li výsledný objekt není prázdný. K tomu použijeme test Is Nothing:

    Set blkref = ent
    If blkref Is Nothing Then
        MsgBox "Nelze získat blok !"
        Exit Sub
    End If

Pomocí netody Name objektu AcadBlockReference zjistíme název bloku, který použijeme pro získání objektu AcadBlock z tabulky AcadBlocks:

    Set definice_bloku = ThisDrawing.Blocks.Item(název_bloku)
    If Err <> 0 Then
        MsgBox "Blok nebyl nalezen!"
    Exit Sub

Funkci Item použijeme také pro přístup k jednotlivým definicím atributů. Ty jsou součástí objektu AcadBlock:

    For i = 0 To blkdef.Count - 1
        Set entita = blkdef.Item(i)
        If Err <> 0 Then
            Exit Sub
        End If
        If StrComp(ent.ObjectName, "AcDbAttributeDefinition", vbTextCompare) = 0 Then
            'definice atributu byla nalezena
            ...
            ...
            End If
        End If
    Next i
End Sub

Výsledný kód funkce by mohl vypadat například takto. Doplnili jsme ještě možnost ponechání původní výzvy tak, že na výzvu GetString lze odpovědět prázdným vstupem (klávesa Enter):

Sub EditAttribPrompts()
    Dim obj As Object
    Dim blkdef As AcadBlock
    Dim blkref As AcadBlockReference
    Dim ent As AcadEntity
    Dim pt As Variant
    
    On Error Resume Next
    ThisDrawing.Utility.GetEntity obj, pt, "Vyberte blok: "
    If Err <> 0 Then
        Exit Sub
    End If
    Set ent = obj
    If StrComp(ent.ObjectName, "AcDbBlockReference", vbTextCompare) <> 0 Then
        MsgBox "Vybraná entita není blok !"
        Exit Sub
    End If
    Set blkref = ent
    If blkref Is Nothing Then
        MsgBox "Nelze získat blok !"
        Exit Sub
    End If
    Set blkdef = ThisDrawing.Blocks.Item(blkref.Name)
    If Err <> 0 Then
        MsgBox "Blok nebyl nalezen!"
        Exit Sub
    End If
    For i = 0 To blkdef.Count - 1
        Set ent = blkdef.Item(i)
        If Err <> 0 Then
            Exit Sub
        End If
        If StrComp(ent.ObjectName, "AcDbAttributeDefinition", vbTextCompare) = 0 Then
            Dim msg As String
            Dim newPrompt As String
            
            msg = "Nová výzva [" & ent.PromptString & "]: "
            newPrompt = ThisDrawing.Utility.GetString(1, msg)
            If (newPrompt <> "") Then
                ent.PromptString = newPrompt
            End If
        End If
    Next i
End Sub