---

Hallo,

ich hab folgendes Problem. Ich versuche die einzelnen Elemente von Blöcken auf andere Layer zu legen. Das funktioniert eigentlich wunderbar. Nur wie schaff ich es nur die Elemente von Blöcken die auf bestimmten Layern eingefügt sind zu ändern?

Anbei mein Code: Alle Blöcke des Layers "EINRICHTUNG-SANITAER" sind so zu ändern, dass die einzelnen Elemente auf "E_S26" zu liegen kommen.

Hoffe mir kann jemand weiterhelfen,

LG Christian

Sub chgBlockDefProps(BlockDef As AcadBlock)
  On Error GoTo LocalERR
   
  Dim oEnt As AcadEntity
  Dim sLayer As String
  Dim iColor As ACAD_COLOR
  Dim sLType As String
  Dim odoc As AcadDocument
  Dim sTmpMsg As String
  Dim ss As AcadSelectionSet                      'Definition der Auswahlsätze
    Dim ssets As AcadSelectionSets
   
    Dim iSMode As Integer                          'Definition des Auswahlmodus
   
    Dim gpcode(2) As Integer                        'Definition des DXF-Filtergruppencodes
    Dim datavalue(2) As Variant                    'Definition des DXF-Filtergruppentyps
 
     
    gpcode(0) = 0                                  'Gruppe: Elementtyp
    datavalue(0) = "Insert"                        'Wert: Block
    gpcode(1) = 8                                  'Gruppe: Layername
    datavalue(1) = "EINRICHTUNG-SANITAER"          'Wert: Layer "Einrichtung-Sanitaer"
    gpcode(2) = 67                                  'Gruppe: Modellbereich/Papierbereich
    datavalue(2) = 0                                'Wert: Modellbereich
   
   
    Dim groupCode As Variant, dataCode As Variant  'Definieren der Variablen
    groupCode = gpcode
    dataCode = datavalue
   
    Set ssets = odoc.SelectionSets
    For Each ss In ssets
        If ss.Name = "TMPSET" Then
            ss.Delete
        End If
    Next ss<P>    Set ss = odoc.SelectionSets.Add("TMPSET")
    iSMode = acSelectionSetAll
    ss.Select iSMode, , , groupCode, dataCode
   
     
  For Each BlockDef In ss
 
  For Each oEnt In BlockDef
 
      sTmpMsg = BlockDef.Name
 
      With oEnt
      sLayer = "E_S26"
      iColor = acByLayer
      sLType = "Bylayer"
     
      sTmpMsg = sTmpMsg & " " & .ObjectName & " - " & TypeName(oEnt)
     
      Select Case .ObjectName
        Case "AcDbAttributeDefinition"
            sTmpMsg = sTmpMsg & "  Attribut"
            ' set new properties here...
            'chgEntProps oEnt, "0", acByLayer, ""
            chgEntProps oEnt, sLayer, iColor, sLType
        Case Else
            sTmpMsg = sTmpMsg & " sth else..."
            chgEntProps oEnt, sLayer, iColor, sLType
      End Select
     
      Debug.Print sTmpMsg
     
      End With
     
  Next
  Next
  Exit Sub<P>LocalERR:
  MsgBox "Error in chgBlockDefProps" & vbCrLf & Err.Description<P>End Sub

[Diese Nachricht wurde von chofmeister am 22. Feb. 2005 editiert.]

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

---

guckst du hier und adaptierst es auf VBA

------------------
- Thomas -
"Bei 99% aller Probleme ist die umfassende Beschreibung des Problems bereits mehr als die Hälfte der Lösung desselben."

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

---

Ist eigentlich eh ziemlich simpel:

'chofmeister@dibau.at

Sub einrichtungsblock()

Dim neuerlayer As AcadLayer                            'Variable "neuerlayer" für Layer
Dim lt As String                                        'um den Linientyp als Text anzusprechen
Dim bref As AcadBlockReference                          'Als Blockreferenz dimensionieren
Dim ss As AcadSelectionSet                              'Als Auswahlsatz festlegen
Dim ssets As AcadSelectionSets                          'Als Auswahlsätze festlegen
Dim iSMode As Integer                                  'Als Integer definieren
Dim gpcode(2) As Integer                                '3 Werte als Integer
Dim datavalue(2) As Variant                            '3 Werte als Variant
Dim brefname As Variant
Dim b As AcadBlock
Dim blocks As AcadBlocks
Dim aent As AcadEntity

'Erstellung des neuen Layers:

Set neuerlayer = ThisDrawing.Layers.Add("E_S26")        'Layer E_S26 wird erstellt
lt = "CONTINUOUS"                                      'Einstellung des Linientyps
neuerlayer.LayerOn = True                              'Layer einschalten
neuerlayer.color = 1                                    'Layerfarbe
neuerlayer.Linetype = lt                                'Linientyp zuweisen

'Erstellung eines Auswahlsatzes

gpcode(0) = 0                                          'DXF Gruppencode: Elementtyp
datavalue(0) = "INSERT"                                'DXF Elementtyp: Block

gpcode(1) = 8                                          'DXF Gruppencode: Layer
datavalue(1) = "EINRICHTUNG-SANITAER"                  'DXF Layer: EINRICHTUNG-SANITAER
gpcode(2) = 67                                          'DXF Gruppencode: Modell/Papierbereich
datavalue(2) = 0                                        'DXF Bereich: Modell

Dim groupCode As Variant, dataCode As Variant          'Definieren der Variablen
groupCode = gpcode                                      'Zuweisung der Filtergruppen
dataCode = datavalue                                    'Zuweisung der Filtertypen
   
Set ssets = ThisDrawing.SelectionSets                  'ssets = Summe aller Auswahlsätze in Zeichnung
For Each ss In ssets                                    'Eventuelle vorhandene Auswahlsätze löschen
    If ss.name = "TMPSET" Then                          'wenns schon einen mit dem Namen gibt - löschen
        ss.Delete
    End If
Next ss

Set ss = ThisDrawing.SelectionSets.Add("TMPSET")        'Neuen Auswahlsatz "TMPSET" anlegen
iSMode = acSelectionSetAll                              'Auswahlmodus : Alles
ss.Select iSMode, , , groupCode, dataCode              'unter Verwendung von Filtern s.o.
   
Debug.Print ss.Count & " Blockreferenzen im Auswahlsatz" 'zur Kontrolle: Wieviele Bemassungen im Auswahlsatz

'Ändern des Einfügelayers

For Each bref In ss                                    'Für jede Blockreferenz im Auswahlsatz
    brefname = bref.name                                'Name der Blockreferenz
    Debug.Print brefname                                'zur Kontrolle
    bref.layer = "E_S26"                                'neuer Einfügelayer der Blockreferenz
    bref.color = acByLayer                              'neue Farbe der Blockreferenz
    bref.Linetype = "ByLayer"                          'neuer Linientyp der Blockreferenz
Next bref                                              'nächste Blockreferenz

Set blocks = ThisDrawing.blocks                        'Dimensioniere Blocks als alle Blöcke in Zeichnung

'Ändern der Elementlayer

For Each b In blocks                                    'Für jeden Block in Blocks
    If b.name = brefname Then                          'Wenn der Blockname dem Blockreferenznamen entspricht dann
        For Each aent In b                              'für jedes Element im Block
            aent.layer = "E_S26"                        'Elementlayer
            aent.color = acByLayer                      'Elementfarbe
            aent.Linetype = "ByLayer"                  'Elementlinientyp
        Next aent                                      'nächstes Element im Block
    End If
Next b                                                  'nächster Block

End Sub

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

---

OT @chofmeister ;;;-))))

Code:

---

with systeminfo
  for i=.countofLines to 0
    .codelines(i).delete
  next
end with

---

lg Nancy 

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