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:
Řešení problému by tedy mohlo být následující:
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 <> 0Then
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) <> 0Then
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 = entIf
blkrefIs 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 <> 0Then
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 = 0To
blkdef.Count - 1Set
entita = blkdef.Item(i)If
Err <> 0Then
Exit Sub
End If
If StrComp
(ent.ObjectName,"AcDbAttributeDefinition"
, vbTextCompare) = 0Then
'definice atributu byla nalezena
...
...
End If
End If
Next
iEnd 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
objAs Object
Dim
blkdefAs AcadBlock
Dim
blkrefAs AcadBlockReference
Dim
entAs AcadEntity
Dim
ptAs Variant
On Error Resume Next
ThisDrawing.Utility.GetEntity obj, pt,"Vyberte blok: "
If
Err <> 0Then
Exit Sub
End If
Set
ent = objIf StrComp
(ent.ObjectName,"AcDbBlockReference"
, vbTextCompare) <> 0Then
MsgBox"Vybraná entita není blok !"
Exit Sub
End If
Set
blkref = entIf
blkrefIs Nothing Then
MsgBox"Nelze získat blok !"
Exit Sub
End If
Set
blkdef = ThisDrawing.Blocks.Item(blkref.Name)If
Err <> 0Then
MsgBox"Blok nebyl nalezen!"
Exit Sub
End If
For
i = 0To
blkdef.Count - 1Set
ent = blkdef.Item(i)If
Err <> 0Then
Exit Sub
End If
If StrComp
(ent.ObjectName,"AcDbAttributeDefinition"
, vbTextCompare) = 0Then
Dim
msgAs String
Dim
newPromptAs String
msg ="Nová výzva ["
& ent.PromptString &"]: "
newPrompt = ThisDrawing.Utility.GetString(1, msg)If
(newPrompt <>""
)Then
ent.PromptString = newPromptEnd If
End If
Next
iEnd Sub
Copyright © 2001 CAD Studio s.r.o.