---

Hallo zusammen,

ich setze mittels VBA-Programm zunächst einen Layer und anschließend wird ein Block incl. Attribute eingefügt.
Funktioniert alles bestens ABER: Wenn ich anschließend den Block auf einen anderen Layer lege, kann ich den Ursprungslayer (wo der Block originär eingfügt wurde) nicht mehr löschen. Erst wenn ich die Blockdefinition ändere (ohne Attribute) kann ich auch den Ursprungslayer löschen.
Natürlich könnte ich hergehen, und den Layer mit entsprechenden Hilfmitteln (Expresstools) entfernen, ich glaube aber, dass am Programmcode etwas verbesserungswürdig wäre - nur was ?

Viele Grüsse

Martin

CODE:
    ThisDrawing.ActiveLayer = ThisDrawing.Layers(strLayer)

    adblInsertPoint(0) = dblRechts
    adblInsertPoint(1) = dblHoch
    adblInsertPoint(2) = 0
   
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(adblInsertPoint, "RefPkt", 1#, 0.5, 1#, 0)

    ' Blockattribute setzen
        For Each varAttribut In blockRefObj.GetAttributes
            Select Case varAttribut.TagString
                Case "PNR": varAttribut.TextString = lngPktNr
                Case "HOE": varAttribut.TextString = strHoehe
            End Select
        Next varAttribut

[Diese Nachricht wurde von MartinM am 17. Oktober 2003 editiert.]

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

---

wenn Du den z.Zt. aktiven Layer löschen möchtest musst Du vorher einen anderen aktiv setzen, z.B. Layer 0. Aktive Layer sind referenziert auch wenn keine Elemente darauf gezeichnet sind.

An Deinem Code dürfte es nicht liegen.

Gruss,
Harry

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

---

Warum machst du eigentlich den Layer aktiv, brauchst du doch gar nicht. Du kannst doch dem Objekt danach den Layer zuweisen.

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

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

---

Hallo,

@Roland: Volltreffer, es funktioniert ! Danke.

Hintergründe für die, die es interessiert: Wenn ein Block mit Attributen in eine aktuelle Zeichnung eingefügt wird, landen selbstverständlicher weise alle Elemente des Blocks, die auf Layer 0 gezeichnet sind, im aktuellen Layer - auch die Attribute !
Wenn ich anschließend den Block auf einen anderen Layer schiebe, bleiben die (unsichtbaren)Attribute auf dem "alten" Layer, der dann natürlich nicht gelöscht werden kann !

Viele Grüsse

Martin

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

---

Hab da ein kleines Tool geschrieben, setzt alle Attribute auf ByBlock und Layer 0.

Code:

---

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 objAtt As AcadAttributeReference
    Dim Count As Integer
   
    On Error GoTo Err_Control
    ' Frage nach den zu bearbeitenden Blöcken
    FltTypes(0) = 0: FltData(0) = "INSERT"
    Set SS = SelectOnScreenFix(FltTypes, FltData, "BlockAttColToByBlockAuswahl")
   
    'SS.SelectOnScreen FltTypes, FltData
   
    If SS.Count = 0 Then GoTo ENDE
   
    For Each BlObj In SS
        If BlObj.HasAttributes Then
            BlAttrib = BlObj.GetAttributes
            For Count = UBound(BlAttrib) To 0 Step -1
                Set objAtt = BlAttrib(Count)
                objAtt.Color = acByBlock
                objAtt.layer = "0"
                objAtt.Lineweight = acLnWtByBlock
            Next Count
        End If
    Next BlObj
    Set BlObj = Nothing
    Set objAtt = Nothing
ENDE:
    SS.Delete
    Set SS = Nothing
Exit_Here:
    Exit Sub
Err_Control:
    Err.Clear
    Resume Exit_Here
End Sub

---

End Sub

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

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

---

hallo ihr alle! nach sowas hab ich schon ewig gesucht.
nur funktioniert es bei mir nicht wenn ich den code in vba eingebe
weiß wer warum??
MFG

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

---

Hallo,

ändere doch mal die Zeilen ein wenig ab.

Code:

---

    'Set SS = SelectOnScreenFix(FltTypes, FltData, "BlockAttColToByBlockAuswahl")
   
    SS.SelectOnScreen FltTypes, FltData

---

SelectOnScreenFix scheint eine Funktion von Roland zu sein die er aber nicht gepostet hat.
SelectOnScreen ist eine aus AutoCAD-VBA

Ausserdem kannst du die Sub ja mal mit F8 im Einzelschritt durchgehen. Dann wirst du sehen wo es hängt.

Wilfried Stelberg

------------------
Warum lisp'eln wenn's auch anders geht.
www.ib-stelberg.de

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

---

danke für die schnelle antwort!
wenn ich das ändere schreibt er mir das nach end sub, end funktion oder end property nur kommentare stehen können.
es steht aber nach end sub nichts mehr

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

---

wenn ich das letzte end sub wegnehme würde es gehen
aber wenn ich im autocad vbaausf eingebe und die dvb ausführe kommt genau nichts. leider kenn ich mich relativ wenig aus.
ich würde um hilfe bitten
dankeschön MFG eilovliz

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

---

Hallo,

dann poste doch mal deinen Code damit man sehen kann wo es hängt.

Wilfried Stelberg

------------------
Warum lisp'eln wenn's auch anders geht.
www.ib-stelberg.de

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

---

ich hab den oberen verwendet ??

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

---

Hallo,

Zitat:

---

wenn ich das letzte end sub wegnehme würde es gehen

---

Wo hast du das gefunden ?

Zitat:

---

ich hab den oberen verwendet ??

---

Es stellt sich auch die Frage wo oben ?

Ich nehme mal an es war dieser hier.

Code:

---

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 objAtt As AcadAttributeReference
    Dim Count As Integer
   
    On Error Resume Next
    Set ss = ThisDrawing.SelectionSets("Att")
    If Err.Number Then
        Set ss = ThisDrawing.SelectionSets.Add("Att")
    End If
   
   
    On Error GoTo Err_Control
    ' Frage nach den zu bearbeitenden Blöcken
    FltTypes(0) = 0: FltData(0) = "INSERT"
     
    ss.SelectOnScreen FltTypes, FltData
   
    If ss.Count = 0 Then GoTo ENDE
   
    For Each BlObj In ss
        If BlObj.HasAttributes Then
            BlAttrib = BlObj.GetAttributes
            For Count = UBound(BlAttrib) To 0 Step -1
                Set objAtt = BlAttrib(Count)
                objAtt.color = acByBlock
                objAtt.Layer = "0"
                objAtt.Lineweight = acLnWtByBlock
                objAtt.Update
            Next Count
        End If
    Next BlObj
    Set BlObj = Nothing
    Set objAtt = Nothing
ENDE:
    ss.Delete
    Set ss = Nothing
Exit_Here:
    Exit Sub
Err_Control:
    Err.Clear
    Resume Exit_Here
End Sub

---

Viel Erfolg

Wilfried Stelberg

PS: klemmt eigentlich deine Shift taste ???

------------------
Warum lisp'eln wenn's auch anders geht.
www.ib-stelberg.de

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

---

das funktioniert super!
aber warum setzt er mit die linien in einem block nicht auf
von layer?kann man das auch machen?
vielen dank für die rasche meldung.
warum soll meine shift taste hängen?
MFG eilovliz

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

---

Hi eilovliz,

Was soll den bei den Linien auf vonLayer gestzt werden?! Du kannst ja den Lininietyp, die Linienstärke, die Farbe usw. auf vonLayer setzen. Da Wilfried oben die Linienstärke und die Farbe schon auf vonBlock gesetzt hat, willst du denke ich den Linientyp ändern.
Das kannst in der Art: "object.Linetype = acLnWtByBlock" oder auf vonLayer machen.

Zur Schift-Taste: Man sollte doch mal mit Groß-/ Kleinschreibung arbeiten, da das lesen des Textes
doch etwas einfacher wird. Und soviel (Mehr-)Aufwand dürfte das doch auch nicht sein, oder?!

Gruß, Carsten

[Diese Nachricht wurde von Carsten1210 am 03. Jul. 2007 editiert.]

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

---

Hy danke für deine Antwort.
Wenn ich einen Block habe der mit Linien und einem Attribut erstellt
wurde. Und alles liegt auf Farbe Rot. Dann wäre es Super wenn ich Praktisch in alle Blöcke eingreifen könnte und alles auf vonlayer setzte.
Weißt du was ich meine?
Vielen Dank MFG eilovliz

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

---

Hi,

Schau mal hier.

Gruß, Carsten

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

---

Super das klingt schon mal sehr gut.
Nur wie bau ich das jetzt am besten in das oben stehende ein?
Bin was das betrifft irgendwie sehr schwach.

MFG eilovliz

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

---

Hallo,

so nun der letzte Versuch.
Mit dieser Funktion kannst du die Blockdefinitionen ändern. Sie ändert auch eventuelle Subblocks in der Definiton ab.
Bei den eingefügten Blöcken werden so auch alle Entitys (ausser den Attributten) geändert, da der Insert ja nur eine Referenz auf die Blockdefinition ist. Bei den Attributten wird beim Einfügen nur die Vorlage aus der Definition verwendet. Sollen hier die Eigenschaften (Layer, Farbe, ..) geändert werden musst du das bei der jeweiligen Einfügung machen. Dafür ist die Funktion aus dem ersten Post.

Code:

---

Public Sub BlockToByBlock()
   
    Dim ObjBlockRef As AcadBlockReference
    Dim objBlockDef As AcadBlock
    Dim dblPkt(0 To 2) As Double
   
    On Error GoTo Err_Control
    ThisDrawing.Utility.GetEntity ObjBlockRef, dblPkt, Chr(10) & "Blockvorlage wählen: "
    On Error GoTo 0
   
    Set objBlockDef = ThisDrawing.Blocks(ObjBlockRef.Name)
  ' SetBlockToDefault objBlockDef, "0", acByLayer  '(256)
    SetBlockToDefault objBlockDef, "0", acByBlock  '(0)
   
    ThisDrawing.Regen acActiveViewport
Exit_Here:
    Exit Sub
Err_Control:
    Err.Clear
    Resume Exit_Here
End Sub

Public Sub SetBlockToDefault(objBlockDef As AcadBlock, strLayer As String, lngColor As Long)
    Dim objEntity As AcadEntity
    ' Jedes Element in der Auflistung zurücksetzen
    For Each objEntity In objBlockDef
        Debug.Print objEntity.ObjectName
        If objEntity.ObjectName = "AcDbBlockReference" Then
          ' Subblocks rekursiv ändern
          SetBlockToDefault ThisDrawing.Blocks(objEntity.Name), strLayer, lngColor
        End If
        objEntity.color = lngColor
        objEntity.Layer = strLayer
    Next objEntity
End Sub

---

Wilfried Stelberg

------------------
Warum lisp'eln wenn's auch anders geht.
www.ib-stelberg.de

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

---

das ist Perfekt! vielen vielen Dank
und das ist meine letzte Frage versprochen
kann man es auch machen das ich mehrere Blöcke bzw alle auf einmal wählen kann??
MFG eilovliz

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

---

Hallo,

dann kopier noch diese Funktion dazu.
Sie ändert in der ganzen Zeichnung die Blöcke, egal ob sie verwendet werden oder nicht.

Code:

---

Public Sub AllBlocksToByBlock()
    Dim objBlockDef As AcadBlock
    For Each objBlockDef In ThisDrawing.Blocks
        If Not objBlockDef.IsLayout And Not objBlockDef.IsXRef Then
            SetBlockToDefault objBlockDef, "0", acByBlock
        End If
    Next objBlockDef
    ThisDrawing.Regen acAllViewports
End Sub

---

Ansonsten hast du in den Funktionen alle Mittel drin aus der Einzelauswahl eine Selektion zu machen. Aber mit der obigen Funktion kann man ganz gut leben.

Wilfried Stelberg

------------------
Warum lisp'eln wenn's auch anders geht.
www.ib-stelberg.de

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

---

ok anscheinend bin ich zu blöd das oben einzufügen.
Ich danke für die vielen Antworten.
MFG eilovliz

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

---

Hallo,

wo hängt es denn ???

Einfach den Code in die Zwischeablage kopieren
und in dein DVB-Modul unten drunter einfügen.

Dann die neue Funktion aufrufen.

Wilfried Stelberg

------------------
Warum lisp'eln wenn's auch anders geht.
www.ib-stelberg.de

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

---

farben.zip

Hier noch die DVB

------------------
Warum lisp'eln wenn's auch anders geht.
www.ib-stelberg.de

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

---

Stelli du bist der beste 
vielen dank für alles.
auf das Hinauf hab ich mir ein Buch bestellt und
gleich einen Kurs gebucht   
vielen Dank
MFG eilovliz

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