Block auf Layer 0 (Autodesk/Rund um AutoCAD)

Hier ein paar Funktionen in VBA geschrieben.
Das erste setzt alle Blockelemente auf Layer 0 und bylayer, das zweite geht alle Attribute durch und setzt diese auf Layer 0.

Code:
' Feletic 10.07.2002
Public Sub BlockToLayer0()
' Setzt alle Elemente eines Blocks auf Layer "0" und ByLayer
Dim SS As AcadSelectionSet
Dim FltTypes(0) As Integer
Dim FltData(0) As Variant

Dim BlRef As AcadBlockReference ' gewählte Blockreferenz
Dim Bl As AcadBlock ' Block ( --> Blockreferenz)
Dim Pt As Variant ' Auswahlpunkt
Dim BlElem As AcadEntity ' Elemente des Blocks

Dim Bag As Collection
Dim Search As Object

' Frage nach den zu bearbeitenden Blöcken
Set SS = CreateSelectionSet("BlöckeNeuzeichAuswahl")
FltTypes(0) = 0: FltData(0) = "INSERT"

' Selectionset erstellen, Benutzer fragen und Filter anwenden
SS.SelectOnScreen FltTypes, FltData

If SS.Count = 0 Then GoTo ENDE

Set Bag = New Collection
For Each BlRef In SS

On Error Resume Next
Set Search = Bag(BlRef.Name)
If Err Then Bag.Add BlRef, BlRef.Name

Next BlRef

Dim Anzahl As Integer
Dim i As Integer

Anzahl = Bag.Count
Do
i = i + 1
Set BlRef = Bag(i)
Set Bl = ThisDrawing.Blocks(BlRef.Name)

For Each BlElem In Bl

If BlElem.ObjectName = "AcDbBlockReference" Then
On Error Resume Next
Set Search = Bag(BlElem.Name)
If Err Then
Bag.Add BlElem, BlElem.Name
Anzahl = Anzahl + 1
End If

End If
BlElem.layer = "0"
BlElem.Color = acByBlock
BlElem.Linetype = acByBlock

Next BlElem

Loop Until i = Anzahl

ENDE:
SS.Delete
ThisDrawing.Regen acAllViewports
' ThisDrawing.Utility.Prompt "Änderungen werden erst nach regenerieren der Zeichnung sichtbar!"

End Sub
' FELETIC - 08.11.2002
Public Sub BlockAttColToByBlock()
' Ändert alle Attribute der gezeigten Blöcke auf Farbe "ByBlock" und Layer "0"

Dim SS As AcadSelectionSet
Dim FltTypes(0) As Integer
Dim FltData(0) As Variant

Dim BlObj As AcadBlockReference
Dim BlAttrib As Variant
Dim Count As Integer

' Frage nach den zu bearbeitenden Blöcken
Set SS = CreateSelectionSet("BlockAttColToByBlockAuswahl")
FltTypes(0) = 0: FltData(0) = "INSERT"

' Selectionset erstellen, Benutzer fragen und Filter anwenden
SS.SelectOnScreen FltTypes, FltData

If SS.Count = 0 Then GoTo ENDE

For Each BlObj In SS
' Jetzt holen wir die Attribute
BlAttrib = BlObj.GetAttributes

' Wir suchen, ob die Daten auch in das neue Ding passen
For Count = UBound(BlAttrib) To 0 Step -1
BlAttrib(Count).Color = acByBlock
BlAttrib(Count).layer = "0"
Next Count
Next BlObj
ENDE:
SS.Delete
End Sub
Public Function CreateSelectionSet(Optional ssName As String = "SS") As AcadSelectionSet

Dim SS As AcadSelectionSet

On Error Resume Next
Set SS = ThisDrawing.SelectionSets(ssName)
If Err Then Set SS = ThisDrawing.SelectionSets.Add(ssName)
SS.Clear
Set CreateSelectionSet = SS
End Function

------------------
Roland

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP