Produkt: AutoCAD 2000i
Datum: 13.03.2001
Pro řešení tohoto problému použijeme VBA. Nejprve si "rozebereme" problém:
Tím, že provedeme změnu v definici bloku, dosáhneme toho, že se změna automaticky projeví u všech referencí.
Definici bloku získáme pomocí kolekce Blocks. Pro vyhledání bloku podle zadaného názvu použijeme výraz:
Dim
blkDefAs AcadBlock
Set
blkDef = ThisDrawing.Blocks.Item(jméno_bloku)
Pokud blok se zadaným názvem v kolekci bloků v aktuálním výkresu existuje, proměnná blkDef se naplní odpovídajícími údaji. V opačném případě systém ohlásí chybu:
Pro ošetření chyby použijeme výraz On Error. V našem případě budeme pokračovat dále v provádění kódu (díry výrazu Resume Next) a otestujeme hodnotu proměnné Err. Pokud není nulová, došlo k chybě. V našem případě použijeme v takovém případě výraz Exit Sub pro ukončení funkce.
Dále projdeme všechny entity uvnitř definice bloku a zkontrolujeme jejich hladinu. Nejjednodušší je použít cyklus For Each:
Dim
subEntAs AcadEntity
For Each
subEntIn
blkDefIf
subEnt.Layer = hledaná_hladinaThen
subEnt.Layer = nová_hladinaEnd If
Next
Spojením obou kódů získáme funkci ChangeBlockLayer:
Sub
ChangeBlockEntLayer(blkNameAs String
, oldLayerAs String
, newLayerAs String
)Dim
blkDefAs AcadBlock
Dim
subEntAs AcadEntity
On Error Resume Next
' vynulovat chybu
Err.ClearSet
blkDef = ThisDrawing.Blocks.Item(blkName)If
Err.Number <> 0Then
Exit Sub
End If
For Each
subEntIn
blkDefIf
subEnt.Layer = oldLayerThen
subEnt.Layer = newLayerEnd If
Next
End Sub
Nakonec doplníme hlavní funkci. Ta bude požadovat výběr bloku, u kterého chceme měnit entity, zadání "nové" a staré hladiny. Pro otesvání správnosti zadaných názvů hladin použijeme volání funkce Item kolekce Layers.
Sub
Macro1()Dim
entAs Object
Dim
ptAs Variant
Dim
oldLayerAs String
Dim
newLayerAs String
Dim
layAs AcadLayer
On Error Resume Next
' vynulovat chybu
Err.Clear ThisDrawing.Utility.GetEntity ent, pt,"Vyberte blok: "
If
Err.Number <> 0Then
Exit Sub
End If
If
ent.EntityName <>"AcDbBlockReference"
Then
MsgBox"Entita není blok !"
Exit Sub
End If
oldLayer = ThisDrawing.Utility.GetString(True
,"Stará hladina: "
)If
Err.Number <> 0Then
Exit Sub
End If
' otestovat, zdali hladina skutečně ve výkrese existuje
Set
lay = ThisDrawing.Layers.Item(oldLayer)If
Err.Number <> 0Then
MsgBox"Hladina neexistuje !"
Exit Sub
End If
newLayer = ThisDrawing.Utility.GetString(True
,"Nová hladina: "
)If
Err.Number <> 0Then
Exit Sub
End If
' otestovat, zdali hladina skutečně ve výkrese existuje
Set
lay = ThisDrawing.Layers.Item(oldLayer)If
Err.Number <> 0Then
MsgBox"Hladina neexistuje !"
Exit Sub
End If
' nyní zavolat funkci pro změnu entit
ChangeBlockEntLayer ent.Name, oldLayer, newLayer' a nakonec zregenerovat výkres
ThisDrawing.Regen acAllViewportsEnd Sub
Na konci hlavní funkce nesmíme zapomenout zavolat metodu Regen s parametrem acAllViewports. To způsobí, že AutoCAD překreslí obsah všech výřezů - tzn. provedené změny v tabulce symbolů (bloků) se zobrazí ve výkrese.
Copyright © 2001 CAD Studio s.r.o.