Jak změnit hladinu objektů uvnitř bloku?

Produkt: AutoCAD 2000i
Datum: 13.03.2001

Pro řešení tohoto problému použijeme VBA. Nejprve si "rozebereme" problém:

V definici bloku musíme projít všechny entity a zkontrolovat jejich hladinu.
Pokud je hladina shodná s hledanou hladinou, změníme hladinu.

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 blkDef As 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 subEnt As AcadEntity
    
For Each subEnt In blkDef
  If subEnt.Layer = hledaná_hladina Then
        subEnt.Layer = nová_hladina
  End If
Next

Spojením obou kódů získáme funkci ChangeBlockLayer:

Sub ChangeBlockEntLayer(blkName As String, oldLayer As String, newLayer As String)
    Dim blkDef As AcadBlock
    Dim subEnt As AcadEntity
    
    On Error Resume Next
    ' vynulovat chybu
    Err.Clear
    Set blkDef = ThisDrawing.Blocks.Item(blkName)
    If Err.Number <> 0 Then
        Exit Sub
    End If
    For Each subEnt In blkDef
      If subEnt.Layer = oldLayer Then
        subEnt.Layer = newLayer
      End 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 ent As Object
    Dim pt As Variant
    Dim oldLayer As String
    Dim newLayer As String
    Dim lay As AcadLayer
            
    On Error Resume Next
    ' vynulovat chybu
    Err.Clear
    ThisDrawing.Utility.GetEntity ent, pt, "Vyberte blok: "
    If Err.Number <> 0 Then
        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 <> 0 Then
        Exit Sub
    End If
    ' otestovat, zdali hladina skutečně ve výkrese existuje
    Set lay = ThisDrawing.Layers.Item(oldLayer)
    If Err.Number <> 0 Then
        MsgBox "Hladina neexistuje !"
        Exit Sub
    End If
    newLayer = ThisDrawing.Utility.GetString(True, "Nová hladina: ")
    If Err.Number <> 0 Then
        Exit Sub
    End If
    ' otestovat, zdali hladina skutečně ve výkrese existuje
    Set lay = ThisDrawing.Layers.Item(oldLayer)
    If Err.Number <> 0 Then
        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 acAllViewports
End 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.