[编程交流] 导出块属性和

;; My Export  -  Lee Mac
;; A generic data extraction program for attributed blocks.
;; 
;; The 'ord' list can contain attribute tags or symbols representing block
;; insertion coordinates.
;; 
;; e.g. ("TAG1" POINT-Y POINT-X "TAG2")
;; 
;; will extract the value of attribute 'TAG1', followed by the Y & X-coordinates
;; of the block insertion point, followed by the value of attribute 'TAG2'.
;; 
;; Point values will be formatted using the current values of the LUNITS & LUPREC
;; system variables.
;;
;; The filename, extension & data delimiter character are all specified at the
;; top of the program code.
(defun c:myexport ( / *error* del des ent idx lst obj ord out sel mlt)
   (defun *error* ( msg )
       (if (= 'file (type des))
           (close des)
       )
       (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
           (princ (strcat "\nError: " msg))
       )
       (princ)
   )
   (setq ord '("POINT" POINT-X POINT-Y "ELEV" "DESC")
         out  (LM:uniquefilename (strcat (getvar 'dwgprefix) (vl-filename-base (getvar 'dwgname))) ".txt")
         del  "\t"
   )
   (if (and (setq sel (ssget '((0 . "INSERT") (66 . 1))))
            (setq mlt (getdist "\nSpecify the Multiplying Factor :"));; added by Tharwat
            )
       (if (setq des (open out "w"))
           (progn
               (repeat (setq idx (sslength sel))
                   (setq ent (ssname sel (setq idx (1- idx)))
                         obj (vlax-ename->vla-object ent)
                   )
                   (setq lst
                       (append
                           (mapcar '(lambda ( a b ) (cons a (rtos (* b mlt)))) ;; modified by Tharwat
                              '(point-x point-y point-z)
                               (trans (cdr (assoc 10 (entget ent))) ent 0)
                           )
                           (mapcar '(lambda ( x ) (cons (strcase (vla-get-tagstring x)) (vla-get-textstring x)))
                               (append
                                   (vlax-invoke obj 'getattributes)
                                   (vlax-invoke obj 'getconstantattributes)
                               )
                           )
                       )
                   )
                   (if (setq lst (vl-remove 'nil (mapcar '(lambda ( x ) (cdr (assoc x lst))) ord)))
                       (write-line (LM:lst->str lst del) des)
                   )
               )
               (setq des (close des))
           )
           (princ (strcat "\nUnable to open file: "" out "" for writing."))
       )
   )
   (princ)
)                
;; List to String  -  Lee Mac
;; Concatenates each string in a list, separated by a given delimiter
(defun LM:lst->str ( lst del )
   (if (cdr lst)
       (strcat (car lst) del (LM:lst->str (cdr lst) del))
       (car lst)
   )
)
;; Unique Filename  -  Lee Mac
;; Returns a unique filename for a given path & file extension
(defun LM:uniquefilename ( pth ext / fnm tmp )
   (if (findfile (setq fnm (strcat pth ext)))
       (progn
           (setq tmp 1)
           (while (findfile (setq fnm (strcat pth "(" (itoa (setq tmp (1+ tmp))) ")" ext))))
       )
   )
   fnm
)
(vl-load-com) (princ)