---

Ich mochte mit einem VBA-Programm Blöcke durchnummerieren
Der Blockname ist bekannt
Der Text für die Nummer ist als Attribut im Block deffiniert z.B. BlockNr
Die Nummerierung soll auf einem bekannten Layer in x-Richtung erfolgen

Ist das möglich?

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

---

Hallo,

das ist möglich, wie so ziemlich alle Objektmanipulationen.

Durch durchläufst den Modellbereich (oder wo auch immer die Objekte zum bearbeiten sind),
prüfst ob es eine Blockreferenz ist,
prüfst ob der EFFECTIVENAME dem gesuchten Blocknamen entspricht,
liest die Attribute der Blockreferenz aus, falls vorhanden
und änderst dann den TextString des Attributes.
Zugleich kannst du dann den Layer des Attributes ändern.

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

---

Hallo usocher, Willkommen im Forum 

Wie cadffm schon schrieb ist das relativ einfach.
Die Frage ist, was bedeutet:
"Die Nummerierung soll auf einem bekannten Layer in x-Richtung erfolgen" ?
und wie gut kennst Du Dich in VBA (für Autocad) aus?

Wenn Du nur bestimmte Blockreferenzen auf einem bestimmten Layer brauchst, würde ich hier vorab einen SelectionsSet mit den beiden Kriterien machen. Diesen kannst Du dann in einer zweiten Liste nach den X-Werten aufsteigend sortieren lassen und danach die Attribute ändern.

BlockReference.EffektiveName kann man verwenden, wäre aber nur bei dynamischen Blöcken notwendig
Für normale Blöcke kann man auch einfach BlockReference.Name verwenden.

Grüße
Klaus 

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

---

Danke für die Info,
gibt es ein Beispielprojekt das ich entsprechend abändern könnte,
ich habe leider nur wenig Erfahrung mit VBA

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

---

Hi,
Beispielprojekte gäbe es viele wenn man die richtigen Suchbegriffe eingibt
Nachdem ich aber zu faul zum suchen bin habe ich hier mal schnell eine Variante codiert
Die oberen Zeilen mußt Du für Dich anpassen
- Gesucht werden alle Blöcke mit einem definierten Namen auf einem definierten Layer
- das angegebene Attribut wird neu beschrieben (von 1 bis .. durchnummeriert)

Wenn Du etwas anderes brauchst, mußt Du das klarer definieren 

Code:

---

Sub BlockNummer()

  Dim BlockName As String
  Dim AttName As String
  Dim LayName As String

  BlockName = "BLOCK_1" ' <<< hier Blockname in Großbuchstaben
  AttName = "BLOCKNR" ' <<< hier Attributnamen sind immer Großbuchstaben
  LayName = "Block_Texte" ' <<< hier Layername der durchsucht werden soll, auf diesem befindet sich der Block
 
  Dim d() As Integer ' in diesem Feld wird sortiert
  Dim dMax As Integer
  Dim L As Integer, L2 As Integer, L3 As Integer
  Dim SSet1 As AcadSelectionSet
  Dim ssMode As Integer
  Dim oBlockRef As AcadBlockReference
  Dim oAttDef As Variant

  ' Definieren der Filter
  Dim FilterType(2) As Integer
  Dim FilterData(2) As Variant
  FilterType(0) = 0: FilterData(0) = "Insert" ' Blöcke
  FilterType(1) = 2: FilterData(1) = BlockName ' Blockname siehe oben
  FilterType(2) = 8: FilterData(2) = LayName ' Layername siehe oben
 
  ' Bereinigen des Selectionsets falls nötig
  On Error Resume Next
  Set SSet1 = Nothing
  ThisDrawing.SelectionSets.Item("SS1").Delete
  On Error GoTo 0
 
  ' Definieren des Selectionsets
  Set SSet1 = ThisDrawing.SelectionSets.Add("SS1")
  ssMode = acSelectionSetAll
  SSet1.Select ssMode, , , FilterType, FilterData
 
  If SSet1.Count > 0 Then ' Gibts es überhaupt Werte ?
    dAkt = 0
    dMax = SSet1.Count - 1
    ReDim d(dMax) As Integer
    For L = 0 To dMax '
      If SSet1(L).ObjectName = "AcDbBlockReference" Then ' wäre nicht nötig
        Set oBlockRef = SSet1(L)
        vx = oBlockRef.InsertionPoint(0)
        If L > 0 Then ' Vergleich Einfügepunkt
          For L2 = L To 1 Step -1
            Set oBlockRef = SSet1(d(L2 - 1))
            If vx < oBlockRef.InsertionPoint(0) Then
              ' aktueller Wert ist kleiner wie letzter Vergleichswert
              ' vorhandene Werte nach hinten schieben
              d(L2) = d(L2 - 1)
            Else
              ' aktuellen Wert einfügen
              d(L2) = L
              ' Vergleich beenden
              Exit For
            End If ' vx < SSet1
          Next L2
          If L2 = 0 Then
            ' einfügen als ersten Wert
            d(L2) = L
          End If
        Else ' ersten Wert setzen
          d(0) = L
        End If ' L > 0 Then
      End If ' SSet1(L).ObjectName
    Next L
'    ' evtl Liste für Kontrolle ausgeben
'    For L = 0 To dMax
'      Set oBlockRef = SSet1(d(L))
'      Debug.Print oBlockRef.InsertionPoint(0)
'    Next L
    ' Blöcke nummerieren
    For L = 0 To dMax ' oder SSet1.Count - 1
      If SSet1(d(L)).ObjectName = "AcDbBlockReference" Then
        Set oBlockRef = SSet1(d(L))
        If oBlockRef.HasAttributes Then
          oAttDef = oBlockRef.GetAttributes
          For L2 = LBound(oAttDef) To UBound(oAttDef)
            If oAttDef(L2).TagString = AttName Then
              oAttDef(L2).TextString = L + 1
              ' oAttDef(L2).Layer = "MeinLayer" ' << falls das Attribut auf einem anderen Layer liegen soll
              Exit For
            End If
          Next L2
        End If ' oBlockRef.HasAttributes
      End If ' SSet1(d(L)).ObjectName
    Next L
  End If ' SSet1.Count > 0 Then
  MsgBox "Bearbeitung beendet"
End Sub

---

Grüße
Klaus 

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

---

Vielen herzlichen Dank.

Es funktoniert!

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