Export Title Blocks to CSV for Lee's Update Title Block

[ziele_o2k]

I wrote this program for my own needs. It was created very quickly and hastily because I needed to update the title blocks in over 40 *.dwg files.
 

When run from as command, it asks for one or several title blocks to retrieve the block names and then exports all blocks on the layouts to a CSV file in a format accepted by the "Lee - update title block" command. The program can also be run as a script where the block name is specified, allowing the export of title blocks in multiple DWG files.

The program is capable of exporting data from blocks with different names and attributes (at least, that is the intention, though I admit I tested it only once on a single project).

The CSV file is exported to the folder where the given DWG file is located. The file name is utb_data.csv.

I probably won't improve the program, but maybe someone will find it useful or want to clean it up.

Function:

(defun c:utbdump nil (dump_blocks_for_utb nil))
; (dump_blocks_for_utb "title_block_v0*")
(defun dump_blocks_for_utb (block_names / ss blk_names atts ss_export lst header) 

    ; (setq xref_lst (cd:SYS_CollList "BLOCK" 32))
    (if block_names 
        (setq ss (ssget "_X" 
                        (list (cons 0 "INSERT") 
                              (cons 2 block_names)
                              (cons 67 1)
                        )
                 )
        )
        (progn (princ "\nSelect blocks to get names ") 
               (setq ss (ssget 
                            (list (cons 0 "INSERT"))
                        )
               )
        )
    )
    (if ss 
        (progn 
            (setq blk_names (mapcar 
                                '(lambda (%) 
                                     (cdr (assoc 2 (entget %)))
                                 )
                                (cd:SSX_Convert ss 0)
                            )
            )
            (setq atts (LM:Unique 
                           (apply 'append 
                                  (mapcar 
                                      '(lambda (%) 
                                           (mapcar 'car (cd:BLK_GetAttsVLA %))
                                       )
                                      (cd:SSX_Convert ss 1)
                                  )
                           )
                       )
            )
            (setq ss_export (ssget "_X" 
                                   (list (cons 0 "INSERT") 
                                         (cons 2 
                                               (gtc:BLK_SsgetFilterNames blk_names)
                                         )
                                         (cons 67 1)
                                   )
                            )
            )
            (setq lst (mapcar 
                          (function 
                              (lambda (%) 
                                  (append 
                                      (list 
                                          (strcat (getvar 'dwgprefix) 
                                                  (getvar 'dwgname)
                                          )
                                          (cdr (assoc 410 (entget %)))
                                          (LM:effectivename %)
                                      )
                                      (if atts 
                                          (mapcar 
                                              '(lambda (%att / att_val) 
                                                   (if 
                                                       (and 
                                                           (setq att_val (cd:BLK_GetAttValueVLA 
                                                                             %
                                                                             %att
                                                                         )
                                                           )
                                                           (not (= att_val ""))
                                                       )
                                                       (strcat "" att_val)
                                                       ""
                                                   )
                                               )
                                              atts
                                          )
                                      )
                                  )
                              )
                          )
                          (cd:SSX_Convert ss_export 0)
                      )
            )
            (setq header (append 
                             (list "DWG" "Layout" "Block")
                             (if atts 
                                 atts
                                 ;  (mapcar '(lambda (%) (strcat "'ATT_NAME: " %)) atts)
                             )
                         )
            )
            (pz:SYS_WriteCSV 
                (strcat (getvar 'dwgprefix) "utb_data.csv")
                (cons header lst)
            )
        )
    )
)


(defun pz:SYS_WriteCSV (Name Lst / old_csv old_header_row new_header_row 
                        union_header_row csv current_header data current_row res_list 
                        row_to_add
                       ) 
    (if (findfile Name) 
        (progn 
            (setq old_csv (LM:readcsv Name))
            (setq old_header_row (car old_csv))
            (setq new_header_row (car Lst))
            (setq union_header_row (LM:ListUnion old_header_row new_header_row))
            (foreach csv (list old_csv Lst) 
                (setq current_header (car csv))
                (setq data (cdr csv))
                (foreach row data 
                    (setq current_row (mapcar 
                                          (function (lambda (%1 %2) (cons %1 %2)))
                                          current_header
                                          row
                                      )
                    )
                    (setq row_to_add (mapcar 
                                         (function 
                                             (lambda (%att / att_val) 
                                                 (if 
                                                     ;  (and
                                                     (setq att_val (cdr 
                                                                       (assoc %att 
                                                                              current_row
                                                                       )
                                                                   )
                                                     )
                                                     ;  (not (= att_val ""))
                                                     ;  )
                                                     att_val
                                                     ""
                                                 )
                                             )
                                         )
                                         union_header_row
                                     )
                    )
                    (setq res_list (cons row_to_add res_list))
                )
            )
            (setq res_list (cons union_header_row (LM:Unique (reverse res_list))))
        )
        (setq res_list Lst)
    )
    (LM:writecsv res_list Name)
)

 

Essential Library Functions:

; =========================================================================================== ;
; Zmienia PICKSET na liste obiektow / Convert PICKSET to list of objects                      ;
;  Ss   [PICKSET] - zbior wskazan / selection sets                                            ;
;  Mode [INT]     - typ zwracanych obiektow / type of returned objects                        ;
;                   0 = ENAME, 1 = VLA-OBJECT, 2 = SAFEARRAY                                  ;
; ------------------------------------------------------------------------------------------- ;
; (cd:SSX_Convert (ssget) 1)                                                                  ;
; =========================================================================================== ;
(defun cd:SSX_Convert (Ss Mode / n res)
  (if
    (and
      (member Mode (list 0 1 2))
      (not
        (minusp
          (setq n
            (if Ss (1- (sslength Ss)) -1)
          )
        )
      )
    )
    (progn
      (while (>= n 0)
        (setq res
          (cons
            (if (zerop Mode)
              (ssname Ss n)
              (vlax-ename->vla-object (ssname Ss n))
            )
            res
          )
              n (1- n)
        )
      )
      (if (= Mode 2)
        (vlax-safearray-fill
          (vlax-make-safearray 9
            (cons 0 (1- (length res)))
          ) res
        )
        res
      )
    )
  )
)


;; Unique  -  Lee Mac
;; Returns a list with duplicate elements removed.

(defun LM:Unique ( l / x r )
    (while l
        (setq x (car l)
              l (vl-remove x (cdr l))
              r (cons x r)
        )
    )
    (reverse r)
)

; =========================================================================================== ;
; Pobiera wartosci wszystkich atrybutow / Gets the values of all attributes                   ;
;  Obj [VLA-Object] - obiekt VLA / VLA-Object                                                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_GetAttsVLA (vlax-ename->vla-object (car (entsel))))                                 ;
; =========================================================================================== ;
(defun cd:BLK_GetAttsVLA (Obj)
  (mapcar
    (function
      (lambda (%)
        (cons
          (vla-get-TagString %)
          (vla-get-TextString %)
        )
      )
    )
    (vlax-invoke Obj (quote GetAttributes))
  )
)

;; @d - [Str/List]
;;      Str - block name - support for wcmatch
;;      List - list of block names

(defun gtc:BLK_SsgetFilterNames (@d / u) 
    (if (= (type @d) 'LIST) 
        (setq @d (cd:STR_ReParse 
                     (LM:Unique 
                         (mapcar 
                             '(lambda (%1) 
                                  (cond 
                                      ((and 
                                           (wcmatch %1 "`**")
                                           (setq tmp (pz:BLK_GetDynBlockNames-S %1))
                                       )
                                       (strcase tmp)
                                      )
                                      ((wcmatch %1 "`**")
                                       (strcase (strcat "`" %1))
                                      )
                                      (T
                                       (LM:escapewildcards (strcase %1))
                                      )
                                  )
                              )
                             @d
                         )
                     )
                     ","
                 )
        )
    )
    ; (if (pz:FilterTabOrLst "BLOCK" @d)
    ; (if (setq u (jk:BLK_GetDynBlockNames-S @d))
    ; (strcat @d ",`" (cd:STR_ReParse u ",`"))
    ; @d
    ; )
    ; nil
    ; )
    (if (setq u (pz:BLK_GetDynBlockNames-S @d)) 
        (strcat @d ",`" (cd:STR_ReParse u ",`"))
        @d
    )
)

; =========================================================================================== ;
; Laczy liste lancuchow w lancuch z separatorem /                                             ;
; Combines a list of strings in the string with the separator                                 ;
;  Lst [LIST] - lista lancuchow / list of strings                                             ;
;  Sep [STR]  - separator / separator                                                         ;
; ------------------------------------------------------------------------------------------- ;
; (cd:STR_ReParse '("OLE2FRAME" "IMAGE" "HATCH") ",")                                         ;
; =========================================================================================== ;
(defun cd:STR_ReParse (Lst Sep / res)
  (setq res (car Lst))
  (foreach % (cdr Lst)
    (setq res (strcat res Sep %))
  )
  res
)

;; Escape Wildcards  -  Lee Mac
;; Escapes wildcard special characters in a supplied string

(defun LM:escapewildcards ( str )
    (vl-list->string
        (apply 'append
            (mapcar
               '(lambda ( c )
                    (if (member c '(35 64 46 42 63 126 91 93 45 44))
                        (list 96 c)
                        (list c)
                    )
                )
                (vl-string->list str)
            )
        )
    )
)

;; Effective Block Name  -  Lee Mac
;; obj - [obj] Block Reference vla object

(defun LM:effectivename ( obj )
    (if (= (type obj) 'ENAME)
        (setq obj (vlax-ename->vla-object obj))
    )
    (vlax-get-property obj
        (if (vlax-property-available-p obj 'effectivename)
            'effectivename
            'name
        )
    )
)

; =========================================================================================== ;
; Pobiera wartosc atrybutu / Gets the attribute value                                         ;
;  Obj [ENAME/VLA-Object] - entycja lub obiekt VLA / entity name or VLA-Object                ;
;  Tag [STR] - etykieta atrybutu / attribute tag                                              ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_GetAttValueVLA (car (entsel)) "VIEW_NUMBER")                                        ;
; =========================================================================================== ;
(defun cd:BLK_GetAttValueVLA (Obj Tag)
  (if (= (type Obj) (quote ENAME))
    (setq Obj (vlax-ename->vla-object Obj))
  )
  (vl-some
    (function
      (lambda (%)
        (if (eq (strcase tag) (strcase (vla-get-TagString %)))
          (vla-get-TextString %)
        )
      )
    )
    (vlax-invoke Obj (quote GetAttributes))
  )
)


;; Write CSV  -  Lee Mac
;; Writes a matrix list of cell values to a CSV file.
;; lst - [lst] list of lists, sublist is row of cell values
;; csv - [str] filename of CSV file to write
;; Returns T if successful, else nil
; (defun c:test ( / fn in lst ss )
    ; (if
        ; (and
            ; (setq ss (ssget '((0 . "POINT"))))
            ; (setq fn (getfiled "Create Output File" "" "csv" 1))
        ; )
        ; (progn
            ; (repeat (setq in (sslength ss))
                ; (setq lst (cons (mapcar 'rtos (cdr (assoc 10 (entget (ssname ss (setq in (1- in))))))) lst))
            ; )
            ; (if (LM:WriteCSV (reverse lst) fn)
                ; (startapp "explorer" fn)
            ; )
        ; )
    ; )
    ; (princ)
; )

(defun LM:writecsv ( lst csv / des sep )
    (if (setq des (open csv "w"))
        (progn
            (setq sep (cond ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))
            (foreach row lst (write-line (LM:lst->csv row sep) des))
            (close des)
            t
        )
    )
)

;; List -> CSV  -  Lee Mac
;; Concatenates a row of cell values to be written to a CSV file.
;; lst - [lst] list containing row of CSV cell values
;; sep - [str] CSV separator token

(defun LM:lst->csv ( lst sep )
    (if (cdr lst)
        (strcat (LM:csv-addquotes (car lst) sep) sep (LM:lst->csv (cdr lst) sep))
        (LM:csv-addquotes (car lst) sep)
    )
)

(defun LM:csv-addquotes ( str sep / pos )
    (cond
        (   (wcmatch str (strcat "*[`" sep "\"]*"))
            (setq pos 0)    
            (while (setq pos (vl-string-position 34 str pos))
                (setq str (vl-string-subst "\"\"" "\"" str pos)
                      pos (+ pos 2)
                )
            )
            (strcat "\"" str "\"")
        )
        (   str   )
    )
)