[编程交流] 修改ATTOUT Lisp以分配S

(setq my_filename "C:\\UserTemp\\Book1.xls")
;;  Groups elements in sublist by criteria
(defun subtrack (test lst)
(apply 'append (mapcar '(lambda (x)
(if (eq (car x) test)(list x))) lst)))
;;  Counts equivalent subs in list
(defun countsub    (lst sub)
 (cond    ((null lst) 0)
   ((and (equal (caar lst) (car sub) 0.00001)
         (equal (cadar lst) (cadr sub) 0.00001)
    )
    (1+ (countsub (cdr lst) sub))
   )
   (T (countsub (cdr lst) sub))
 )
)
;;  Get info from block include from constant attributes in following form:
;; (("TAG1" . "VALUE1") ("TAG2" . "VALUE2") ...("*CONSTANT*: TAGN" . "VALUEN"))
 (defun get-all-atts (obj / atts att_list const_atts const_list ent)
   (and
    (if (and obj 
         (vlax-property-available-p obj 'Hasattributes)
         (eq :vlax-true (vla-get-hasattributes obj))
        )
      (progn
        (setq atts (vlax-invoke obj 'Getattributes))
        (foreach att atts
          (setq att_list
             (cons (cons (vla-get-tagstring att)
                 (vla-get-textstring att)
               )
               att_list
             )
          )
        )
      )
    )
   )
   (cond ((vlax-method-applicable-p obj 'Getconstantattributes)
      (setq const_atts (vlax-invoke obj 'Getconstantattributes))
      (foreach att    const_atts
        (setq const_list
           (cons (cons    (vla-get-tagstring att)
               (vla-get-textstring att)
             )
             const_list
           )
        )
      )
      (setq att_list (reverse (append const_list att_list)))
     )
     (T (reverse att_list))
   )
 )
;;            Main part            ;;
 (defun C:ATOUT (/     acsp      adoc       aexc        awb         axss
       bname     cll      colm       com_data csht     data
       exc_data fname      header_list        info     nwb
       osm     row      sht       ss        str1     str2
       subtot     tmp_data tmp_get  tmp_snip tot
          )
   (vl-load-com)
   (setq adoc (vla-get-activedocument
        (vlax-get-acad-object)
          )
     acsp (vla-get-modelspace adoc)
   )
   (setq osm (getvar "osmode"))
   (setvar "osmode" 0)
   (setvar "cmdecho" 0)
   (vla-endundomark adoc)
   (vla-startundomark adoc)
   (vl-cmdf "zoom" "a")
   (vl-cmdf "zoom" ".85x")
   ;;    variations of the selection
   ;;  All blocks :
       (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 66 1))))
   ;;    Selected on screen:
;;;(setq ss (ssget '((0 . "INSERT"))))
   ;; All blocks by name:
;;;    (setq bname (getstring "\n    ***    Block name:\n"))
;;;    (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 66 1) (cons 2 bname))))
   (setq axss (vla-get-activeselectionset adoc))
   (setq com_data nil)                  ;for debug only
   (vlax-for a    axss
     (setq tmp_get (get-all-atts a))
     (setq tmp_data (append (list (vla-get-name a)(vla-get-handle a)) tmp_get))
     (setq com_data (cons tmp_data com_data))
     (setq tmp_data nil)
   )                          ;ok
   (setq tot (length com_data))
   (setq exc_data nil)                  ;for debug only
   (while com_data
     (setq tmp_snip
        (subtrack (caar com_data) com_data)
     )
     (setq str1 (strcat "Subtotal blocks "
            """ (caar com_data) """
                        ": "
        )
       str2
        (itoa (length tmp_snip))
     )
     (setq exc_data (append exc_data
                (list (append tmp_snip (list (list str2 str1))))
            )
       com_data (vl-remove-if
              (function not)
              (mapcar (function (lambda (x)
                      (if (not (member x tmp_snip))
                        x
                      )
                    )
                  )
                  com_data
              )
            )
       tmp_snip nil
     )
   )
   (setq exc_data
          (mapcar (function (lambda (x)
              (mapcar (function (lambda (y)                
                  (append (list (cadr y)(car y))(cddr y))))
                      x
                      )
                              )
                            )
                  exc_data)
                  )
   ;;        Eof calc part        ;;
   ;;    ***    Excel part    ***    ;;
   ;;(setq fn (vl-filename-base (getvar "dwgname")))
   ;;(setq fname (strcat (getvar "dwgprefix") fn ".xls"))
   ;;(setq fname (open fname "W"))
   ;;(close fname)
   (setq fn (vl-filename-base (getvar "dwgname")))
   (setq fname my_filename)    ;; open in read-write.  
   ;;(setq fname (open fname "W"))
   ;;(close fname)
   (princ "*")
   (princ fname)
   (setq fname (findfile fname))
   ;;; Excel part written by  ALEJANDRO LEGUIZAMON -  http://arquingen.tripod.com.co  
   (princ "*")
   (setq aexc (vlax-get-or-create-object "Excel.Application")
     awb  (vlax-get-property aexc "Workbooks")
     nwb  (vlax-invoke-method awb "Open" fname)
     sht  (vlax-get-property nwb "Sheets")
     csht (vlax-get-property sht "Item" 1)
     cll  (vlax-get-property csht "Cells")
   )
   (vlax-put-property csht 'Name "AttOut-AttIn")
   (vla-put-visible aexc :vlax-true)
   (setq row 1
     colm 1
   )
   (setq header_list
          '("HANDLE"
            "BLOCK NAME"
            "TAG1"
            "TAG2"
            "TAG3"
            "TAG4"
            "TAG5"
            "TAG6"
            "TAG7"
            "TAG8"
            "TAG9"
            "TAG10"
           )
   ) ;_ end of setq
   (repeat (length header_list)
     (vlax-put-property
   cll
   "Item"
   row
   colm
   (vl-princ-to-string (car header_list))
     )
     (setq colm (1+ colm)
       header_list
        (cdr header_list)
     )
   )
   (setq row 2
     colm 1
   )
   (repeat (length exc_data)
     (setq data   (reverse (cdr (reverse (car exc_data))))
       subtot (last (car exc_data))
     )
     (repeat (length data)
   (setq info (car data))
   (repeat    (length info)
     (vlax-put-property
       cll
       "Item"
       row
       colm
           (if (< colm 3)
       (vl-princ-to-string (car info))
           (vl-princ-to-string (cdar info)))
     )
     (setq colm (1+ colm))
     (setq info (cdr info))
   )
       (setq data (cdr data))
   (setq row  (1+ row)
         colm 1
   )
     )
     (vlax-put-property
   cll
   "Item"
   row
   colm
   (vl-princ-to-string (car subtot))
     )
     (setq colm (1+ colm))
     (vlax-put-property
   cll
   "Item"
   row
   colm
   (vl-princ-to-string (cadr subtot))
     )
     (setq exc_data (cdr exc_data))
     (setq row     (1+ row)
       colm 1
     )
   )
   (setq row  (1+ row)
     colm 1
   )
   (vlax-put-property
     cll
     "Item"
     row
     colm
     (vl-princ-to-string "TOTAL BLOCKS:")
   )
   (setq colm (1+ colm))
   (vlax-put-property
     cll
     "Item"
     row
     colm
     (vl-princ-to-string tot)
   )
  (setq fcol (vlax-get-property csht "Range" "A:Z"))
  (vlax-put-property fcol "NumberFormat" "@")
;;;        Columns("A:A").Select
;;;    Range("A394").Activate
;;;    Selection.NumberFormat = "@"
   (vlax-invoke (vlax-get-property csht "Columns") "AutoFit")
   (vlax-release-object cll)
   (vlax-release-object fcol)
   (vlax-release-object csht)
   (vlax-release-object sht)
   (vlax-release-object nwb)
   (vlax-release-object awb)
   (vlax-release-object aexc)
   (setq aexc nil)
   (setvar "osmode" osm)
   (setvar "cmdecho" 1)
   (vla-clear axss)
   (vlax-release-object axss)
   (vla-regen adoc acactiveviewport)
   (vla-endundomark adoc)
   (gc)
   (gc)
   ;; (alert "Save Excel manually")
   (princ "\nSave Excel manually: \n")
   (princ)
   )
(princ "\n\t\t***\tStart command with ATOUT...\t***")
(princ)