---

Guten Morgen,

habe mein Skript überarbeitet. Sollte eigentlich funktionieren aber irgendein Fehler ist drinn.

Anforderung: Ich möchte die Zeichnung nach allen Blöcken auf dem Layer "Einrichtung-Sanitaer" durchsuchen. Die Namen dieser  Blockreferenzen sollen übertragen werden und jeder Block ind der Blocktabelle dessen Namen mit der Blockreferenz übereinstimmt soll verändert werden.

Code:
Sub chgAllBlockDefs(odoc As AcadDocument)
  On Error GoTo LocalERR

Dim iDummy As Integer
Dim iBCounted As Long
Dim aent As AcadObject
Dim sObjName 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 = ThisDrawing.SelectionSets                      'Erstellen des Auswahlsatzes
    For Each ss In ssets                                'Eventuelle vorhandene Auswahlsätze löschen
        If ss.name = "TMPSET" Then
          ss.Delete
        End If
    Next ss

    Set ss = ThisDrawing.SelectionSets.Add("TMPSET")
    iSMode = acSelectionSetAll                          'Alles Markieren
    ss.Select iSMode, , , groupCode, dataCode          'unter Verwendung von Filtern
   
   
    Debug.Print ss.Count & " Block references in selection set"
    iBCounted = 0
    Dim bref As AcadBlockReference
    For Each aent In ss
    Set bref = aent
    Dim brefname As Variant
    brefname = bref.name
   
    Debug.Print "3333 BLOCKNAME TEST" & brefname
    Dim block As AcadBlock
    Dim blocks As AcadBlocks
    Dim sBlockName As Variant

Bis hierhin funktioniert alles. Die Namen der Blockreferenzen werden korrekt ausgegeben. Jetzt möchte ich diese Namen mit den Blockdefinitionen vergleichen:

sBlockName = block.name
    Set blocks = ThisDrawing.blocks
   
    For Each block In blocks
 
 
  ' * ... all unnamed
  ' *U unnamed user defined, *D dimensions, *X old hatches
  '
  ' change criteria to your likings....
  ' (remove redundancy etc)
 
 
  If block.IsXRef Or block.IsLayout _
      Or (Left(sBlockName, 1) = "*") _
      Or (Left(sBlockName, 2) = "*U") _
      Or (Left(sBlockName, 2) = "*D") _
      Or (Left(sBlockName, 2) = "*X") _
      Then
      iDummy = 0 ' q&d so the THEN is valid...
'      Debug.Print "[" & sBlockName & "] ignored"
  Else
      If block.name brefname Then
      chgBlockDefProps block
      iBCounted = iBCounted + 1
        'Else
        'iDummy = 0
        'End If
   
  End If
Next block
Next aent
  Debug.Print "Blockdefs processed: " & iBCounted
Exit Sub

LocalERR:
  MsgBox "Error in chgAllBlockDefs" & vbCrLf & Err.Description

End Sub

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