Data Extraction from dynamic blocks

[AsRe1301]

Hello everyone,

I need your help because I just don't know what to do anymore.
I wrote a LISP program, which should loop through all my blocks in a drawing (dynamic and non-dynamic) and write some infos in a CSV-file.
So far so good...
And here starts the trouble, I hope I can explain it:
There are about 50 blocks in the drawing (most non-dynamic), which may also contain blocks (and maybe some more nested blocks, also a mix of dynamic & non-dynamic)
My program starts by selecting all blocks and loops through them.
In "ProcessBlockAndSubBlocks " I check if the block is dynamic and starts with "Bohrung" or "Gewinde" => if yes get the Infos and write it to CSV...

Here is my first problem: The main block may be for example on z-Coordinate 264, but I get the z-Coordinate for the nested Block in the block which is 0 (?)
First question: How can I get the global z-coordinate from the nested-blocks

Second problem - I tried to make a recursive loop so I can also search through nested blocks in my blocks.
It works for two time nested blocks, but I don't get all informations from my first level block...

Here is my code

(defun CheckDynamicBlock (blk)
  (setq props (vlax-invoke blk 'GetDynamicBlockProperties))
  (if props
    t   ; Block ist dynamisch
    nil ; Block ist nicht dynamisch
  )
)

(defun ProcessBlockAndSubBlocks (blk outfile orgblk)
  (setq orgblkname (vla-get-effectivename orgblk))
;(alert (strcat "orgblkname" orgblkname))
  (setq blkname (vla-get-effectivename blk))
;(alert (strcat "blkname" blkname))
  (if (and (or (equal (strcase (substr blkname 1 7)) "BOHRUNG") (equal (strcase (substr blkname 1 7)) "GEWINDE")) (CheckDynamicBlock blk)) ; Überprüfen, ob der Name mit "Bohrung" oder "Gewinde" beginnt und ob der Block dynamisch ist
    (progn    
      (setq propnames-list '()) ; Ein leeres Array für die propnames erstellen
      (setq propvalues-list '()) ; Ein leeres Array für die propvalues erstellen
      (setq direction-x-value nil) ; Variable für Richtung X initialisieren
      (setq direction-y-value nil) ; Variable für Richtung Y initialisieren
      (setq propnames-list (cons "Dateiname" propnames-list)) ; Dateiname dem Array hinzufügen
      (setq current-filename (getvar "dwgname"))
      (setq propvalues-list (cons current-filename propvalues-list)) ; Dateiname dem Array hinzufügen
      (setq blkname (vla-get-effectivename blk))
      (setq propnames-list (cons "Name" propnames-list)) ; Blockname dem Array hinzufügen
      (setq propvalues-list (cons blkname propvalues-list)) ; Blockname dem Array hinzufügen
      (setq inspnt (vlax-safearray->list(vlax-variant-value(vlax-get-property blk 'InsertionPoint))))
      (setq propnames-list (cons "Position X" propnames-list)) ; Position X dem Array hinzufügen
      (setq x (car inspnt)) ; Position X
      (setq x (format-value x))
      (setq propvalues-list (cons x propvalues-list)) ; Position X dem Array hinzufügen
      (setq propnames-list (cons "Position Y" propnames-list)) ; Position Y dem Array hinzufügen
      (setq y (cadr inspnt)) ; Position Y
      (setq y (format-value y))
      (setq propvalues-list (cons y propvalues-list)) ; Position Y dem Array hinzufügen
      (setq propnames-list (cons "Position Z" propnames-list)) ; Position Z dem Array hinzufügen
      (setq z (caddr inspnt)) ; Position Z
      (setq z (format-value z))            
      (setq propvalues-list (cons z propvalues-list)) ; Position Z dem Array hinzufügen
      (setq props (vlax-invoke blk 'GetDynamicBlockProperties)) ; auslesen der dynamischen Eigenschaften
      (foreach prop props
        (setq propname (vla-get-propertyname prop))
          (cond (
            (member propname '("Ebene" "bisEbene" "Winkel" "Länge" "Gewindelänge" "Kernlochtiefe" "Drehung" "Richtung X" "Richtung Y"))    
            (setq propvalue (vlax-variant-value (vla-get-value prop)))
            (if (or (numberp propvalue) (equal propname "Winkel"))
                (progn
                  (if (equal propname "Drehung")
                      (setq propvalue (* (/ propvalue pi) 180)))                  
                  (if (equal propname "Winkel")
                      (setq propvalue (rtos (atof propvalue) 2 8)) ; Wandelt den Wert von "Winkel" in eine Zahl um und ergänzt acht Nachkommastellen
                    (setq propvalue (rtos propvalue 2 8))) ; Begrenzt auf maximal acht Nachkommastellen
                  (setq propvalue (format-value (atof propvalue)))
                )
              (setq propvalue (strcat propvalue)) ; Sicherstellen, dass propvalue eine Zeichenkette ist
            )
            (setq propnames-list (cons propname propnames-list)) ; propname dem Array hinzufügen
            (setq propvalues-list (cons propvalue propvalues-list)) ; propvalue dem Array hinzufügen    
            ;; Überprüfen und Zuweisung für Richtung X und Richtung Y
            (if (equal propname "Richtung X")
                (setq direction-x-value propvalue)
              (if (equal propname "Richtung Y")
                  (setq direction-y-value propvalue)
              )
            )                
          )
         )
      )
      (setq propnames-list (cons "Position RX" propnames-list)) ; Position RX dem Array hinzufügen
      (setq pos-rx (+ (atof x) (atof direction-x-value))) ; Neue X-Position berechnen
      (setq pos-rx (format-value pos-rx))
      (setq propvalues-list (cons pos-rx propvalues-list)) ; Position RX dem Array hinzufügen                
      (setq propnames-list (cons "Position RY" propnames-list)) ; Position RY dem Array hinzufügen
      (setq pos-ry (+ (atof y) (atof direction-y-value))) ; Neue Y-Position berechnen
      (setq pos-ry (format-value pos-ry))
      (setq propvalues-list (cons pos-ry propvalues-list)) ; Position RY dem Array hinzufügen                
      (setq propnames-list (cons "Position RZ" propnames-list)) ; Position RZ dem Array hinzufügen
      (setq pos-rz (atof z)) ; Z-Koordinate bleibt unverändert
      (setq pos-rz (format-value pos-rz))
      (setq propvalues-list (cons pos-rz propvalues-list)) ; Position RZ dem Array hinzufügen                
      (setq export "") ; Leere Zeichenkette für den Export initialisieren
      (foreach propvalue (reverse propvalues-list)
        (setq export (strcat export (strcat propvalue ",")))
       ) ; Elemente zur Zeichenkette hinzufügen
      (setq export (substr export 1 (- (strlen export) 1))) ; Letztes Komma entfernen
      (write-line export outfile) ; Blocknamen, Layernamen und Koordinaten in die CSV-Datei schreiben
    )
  ) ;ENDE DER SCHLEIFE, WENN ES SICH UM EINEN DYNAMISCHEN BLOCK HANDELT UND DIESER IN DIE CSV EINGETRAGEN WERDEN SOLL

  (if (and (not (or (equal (strcase (substr blkname 1 7)) "BOHRUNG") (equal (strcase (substr blkname 1 7)) "GEWINDE"))) (not (CheckDynamicBlock blk)))
  ; wenn der Block nicht mit Gewinde oder Bohrung beginnt UND NICHT dynamisch ist, dann überprüfe, ob der Block noch Blöcke enthält
   (progn
     (if (setq ent (tblobjname "block" blkname))
     (progn
;     (if (setq ent (tblobjname "block" orgblkname))
;      (setq orgblkname (vla-get-effectivename orgblk))     
       (while (and ent (setq ent (entnext ent)))
         (if  (= (cdr (assoc 0 (entget ent))) "INSERT") ; Überprüfen, ob es sich um ein Insert-Objekt (Block) handelt    
           (progn
             (setq subblk (vlax-ename->vla-object ent))
             (setq sblkname (vla-get-effectivename subblk))
;             (alert (strcat "sblkname" sblkname))
             (prompt (strcat "\n" "-" orgblkname "-" sblkname "-" (cdr (assoc 0 (entget ent)))))
             (ProcessBlockAndSubBlocks subblk outfile orgblk)    
           )
         )
       )
))
   )
 )
)

(defun c:listtocsv ()
;(alert "JA")
  (setq dwgpath (getvar "DWGPREFIX")) ; Pfad zur DWG-Datei
  (setq dwgname (getvar "DWGNAME"))   ; Name der DWG-Datei ohne Erweiterung
  (setq csvpath (strcat dwgpath dwgname ".csv")) ; Pfad zur CSV-Datei
  (setq outfile (open csvpath "w")) ; Öffne die CSV-Datei im Schreibmodus

  (setq headlines '("Dateiname" "Name" "Position X" "Position Y" "Position Z" "Ebene" "bisEbene" "Winkel" "Länge" "Gewindelänge" "Kernlochtiefe" "Drehung" "Richtung X" "Richtung Y" "Position RX" "Position RY" "Position RZ"))

  (if outfile
    (progn
      (write-line (apply 'strcat (mapcar '(lambda (x) (strcat x ",")) headlines)) outfile) ; Überschrift in die CSV-Datei schreiben      
      (setq ss (ssget "X" '((0 . "INSERT")))) ; Alle Blöcke auswählen
      (if ss
        (progn
          (setq numobjs (sslength ss))
          (setq i 0)
          (while (< i numobjs)
            (setq ent (ssname ss i))
            (setq blk (vlax-ename->vla-object ent))
            (ProcessBlockAndSubBlocks blk outfile blk)
            (setq i (1+ i))
          )
        )
      )
      (close outfile) ; CSV-Datei schließen
      (princ (strcat "Blocknamen und Koordinaten wurden in die Datei " csvpath " geschrieben."))
    )
    (princ "Fehler beim Öffnen der CSV-Datei.")
  )
  (princ)
)

(defun format-value (value)
  (setq original-value value)
  (setq decimal-point-pos (vl-string-search "." (rtos value 2 10)))
  (if decimal-point-pos
    (progn
      (setq length-to-fill (- 10 decimal-point-pos))
      (setq value (strcat (rtos value 2 10) (substr "00000000" 1 length-to-fill))))
    (setq value (strcat (rtos value 2 10) ".00000000")))
 
  ;; Kürzen auf maximal acht Stellen nach dem Punkt
  (setq decimal-point-pos (vl-string-search "." value))
  (if decimal-point-pos
    (progn
      (setq integer-part (substr value 1 decimal-point-pos)) ; Alle Zeichen vor dem Punkt
      (setq decimal-part (substr value (+ decimal-point-pos 2) 8)) ; +2, um den Punkt zu überspringen
      (setq value (strcat integer-part "." decimal-part))
    )
  )
  value
)

I attached my test drawing, which contains some of my blocks for testing.

Thanks to everyone who takes time to help me.

Kind regards,
René

[AsRe1301]

Hello again,

Apparently this problem is not that easy to solve, so I would have tried a new approach.
I have expanded my processblockandsubblocks routine with the following entry:

  (if (setq ent1 (tblobjname "block" orgblkname))
    (while (and ent1 (setq ent1 (entnext ent1)))
      (if  (= (cdr (assoc 0 (entget ent1))) "INSERT") ; Überprüfen, ob es sich um ein Insert-Objekt (Block) handelt	
        (progn
	      (setq subblk (vlax-ename->vla-object ent1))
	      (setq sblkname (vla-get-effectivename subblk)) 
	      (if (CheckDynamicBlock subblk)
            (progn
              ; Dynamischen Block verarbeiten
              (setq dynamic_blocks (cons sblkname dynamic_blocks))
		  (alert (strcat "DYNAMISCH " sblkname))
            )
            (progn
              ; Nicht-dynamischen Block verarbeiten
              (setq non_dynamic_blocks (cons sblkname non_dynamic_blocks))
		  (alert (strcat "NICHTDYNAMISCH " sblkname))			  
            )
          )

          (setq getnext "true")
		)
	  )
	)
  )

If a non-dynamic block is found, I would like to temporarily exclude it from the block and then add it back in so that it is ranked all the way down. I believe that this could solve my problem. but how do I exclude the block and add it back??
(vla-delete subblk) does delete it and I can't insert it again.
Any idea for this?

Thanks again for reading,
René

[peter]

This code gives you a list of ALL blocks and nested block vla-objects

P=

;___________________________________________________________________________________________________________|
;
; Written By: Peter Jamtgaard copyright 2024 All Rights Reserved
;___________________________________________________________________________________________________________|
;
;___________________________________________________________________________________________________________|
;
; Comand line function list
;___________________________________________________________________________________________________________|

;* C:Nested
;* Command line function to get a list of ALL block vla-objects including nested blocks

;___________________________________________________________________________________________________________|
;
; General Functions and Subroutines Header List
;___________________________________________________________________________________________________________|

;* (BlockDefinition1 objBlock)
;* Function to get a block definition of a block reference

;* (BlocksNestedList objBlock)
;* Function to get a list of a block vla-objects including nested blocks

;$ EndHeader
;___________________________________________________________________________________________________________|
; 
; Command line function to get a list of all block vla-objects including nested blocks
;___________________________________________________________________________________________________________|

(defun C:Nested (/ entSelection intCount lstNestedBlocks objSelection ssSelections)
 (if (setq ssSelections (ssget "X" (list (cons 0 "insert"))))
  (repeat (setq intCount (sslength ssSelections))
   (if (and (setq intCount (1- intCount))
            (setq entSelection (ssname ssSelections intCount))
            (setq objSelection (vlax-ename->vla-object entSelection))
       )
    (BlocksNestedList objSelection)
   )
  )
 )
 lstNestedBlocks
)

;___________________________________________________________________________________________________________|
; 
; Function to get a block definition of a block reference
;___________________________________________________________________________________________________________|

(defun BlockDefinition1 (objBlock / strBlockName)
 (if (setq strBlockName (vla-get-name objBlock))
  (vla-item objGlobalBlockDefinitions strBlockName)
 )
)

;___________________________________________________________________________________________________________|
; 
; Function to get a list of a block vla-objects including nested blocks
;___________________________________________________________________________________________________________|

(defun BlocksNestedList (objBlock 
                         / 
                         objItem
                         strEffectiveName 
                        )
 (if (and (wcmatch (vla-get-objectname objBlock) "AcDbBlockReference,AcDbMInsertBlock") 
          (setq strEffectiveName     (strcase (vla-get-effectivename objBlock)))
          (/= (substr strEffectiveName 1 1) "*")
          (setq lstNestedBlocks (cons objBlock 
                                      lstNestedBlocks
                                )
          )
     )
  (vlax-for objItem (blockdefinition1 objBlock); Returns Unknown Block Object             
   (if (wcmatch (vla-get-objectname objItem) "AcDbBlockReference,AcDbMInsertBlock")        
    (BlocksNestedList objItem)
   )  
  )
 )
 lstNestedBlocks
)

;___________________________________________________________________________________________________________|
; 
; Initialization Function to get the blocks collection and save it for later reference.
;___________________________________________________________________________________________________________|

(vl-load-com)

(setq objGlobalBlockDefinitions (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))

(princ "!")

(vl-load-com)