[编程交流] 例行Lisp

(setq ss (ssget "X" (list (cons 0 "INSERT") (cons 2 "BLOCKNAME")
                         (if (getvar "CTAB")
                             (cons 410 (getvar "CTAB"))
                             (cons 67 (- 1 (getvar "TILEMODE")))))))

(vl-load-com)
(defun mip-conv-to-str    (dat)
 (if dat
   (vl-princ-to-string dat)
   ""))
(defun get-all-atts  (obj)
 (if (and obj
      (eq :vlax-true (vla-get-HasAttributes obj))
      (vlax-property-available-p obj 'Hasattributes))
   (vl-catch-all-apply
     (function    (lambda    ()
         (mapcar (function (lambda (x)
                     (cons (vla-get-TagString x)
                       (vla-get-TextString x))))
             (append (vlax-invoke obj 'Getattributes)
                 (vlax-invoke obj 'Getconstantattributes)
                 )))))))
;|================== XLS ========================================
* Purpose: Export of the list of data punto_datos in Excell
*             It is exported to a new leaf of the current book.
             If the book is not present, it is created
* Arguments:
             punto_datos - The list of lists of data (LIST) 
                           ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                           Each list of a kind (Value1 Value2... VlalueN) enters the name in
                           a separate line in corresponding columns (Value1-A Value2-B and .ò.ä.)
                 header -  The list (LIST) headings or nil a kind (" Signature A " " Signature B "...)
                           If header nil, is accepted ("X" "Y" "Z")
                Colhide -  The list of alphabetic names of columns to hide or nil - to not hide ("A" "C" "D") - to hide columns A, C, D
                Name_list - The name of a new leaf of the active book or nil - is not present
* Return: nil
* Usage
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Col1" "Col2" "Col3"  "Col4") '("B") "test")   |;
(vl-load-com)
(defun xls  (punto_datos    header       Colhide      Name_list     /        *aplexcel*     *books-colection*
        Currsep        *excell-cells* *new-book*      *sheet#1*     *sheet-collection*           col
        iz_listo        row           cell          cols)
 (defun Letter     (N / Res TMP)
   (setq Res "")
   (while (> N 0)
     (setq TMP    (rem N 26)
       TMP    (if (zerop TMP)
         (setq    N   (1- N)
           TMP 26)
         TMP)
       Res    (strcat (chr (+ 64 TMP)) Res)
       N    (/ N 26)))
   Res)
 (if (null Name_list)
   (setq Name_list ""))
 (setq *AplExcel* (vlax-get-or-create-object "Excel.Application"))
 (if (setq *New-Book* (vlax-get-property *AplExcel* "ActiveWorkbook"))
   (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
     *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
     *Sheet#1*         (vlax-invoke-method *Sheet-Collection* "Add"))
   (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
     *New-Book*         (vlax-invoke-method *Books-Colection* "Add")
     *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
     *Sheet#1*         (vlax-get-property *Sheet-Collection* "Item" 1)))
 (setq *excell-cells* (vlax-get-property *Sheet#1* "Cells"))
 (setq    Name_list (if (= Name_list "")
           (vl-filename-base (getvar "DWGNAME"))
           (strcat (vl-filename-base (getvar "DWGNAME")) "&" Name_list))
   col      0
   cols      nil)
 (vlax-for sh *Sheet-Collection* (setq cols (cons (strcase (vlax-get-property sh 'Name)) cols)))
 (setq row Name_list)
 (while (member (strcase row) cols)
   (setq row (strcat Name_list " (" (itoa (setq col (1+ col))) ")")))
 (setq Name_list row)
 (vlax-put-property *Sheet#1* 'Name Name_list)
 (setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))
 (vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_êå èñïîëüçîâêòü ñèñòåìêûå óñòêêîâêè
 (vlax-put-property *AplExcel* "DecimalSeparator" ".") ;_ðêçäåëèòåëü äðîáêîé è öåëîé ÷êñòè
 (vlax-put-property *AplExcel* "ThousandsSeparator" " ") ;_ðêçäåëèòåëü òûñÿ÷åé
 (vla-put-visible *AplExcel* :vlax-true)
 (setq    row 1
   col 1)
 (if (null header)
   (setq header '("X" "Y" "Z")))
 (repeat (length header)
   (vlax-put-property
     *excell-cells*
     "Item"
     row
     col
     (vl-princ-to-string (nth (1- col) header)))
   (setq col (1+ col)))
 (setq    row 2
   col 1)
 (repeat (length punto_datos)
   (setq iz_listo (car punto_datos))
   (repeat (length iz_listo)
     (vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
     (setq iz_listo (cdr iz_listo)
       col         (1+ col)))
   (setq punto_datos (cdr punto_datos))
   (setq col 1
     row (1+ row)))
 (setq    col (1+ (length header))
   row (1+ row))
 (setq    cell (vlax-variant-value
          (vlax-invoke-method
        *Sheet#1*
        "Evaluate"
        (strcat "A1:" (letter col) (itoa row))))) ;_ end of setq
 (setq cols (vlax-get-property cell 'Columns))
 (vlax-invoke-method cols 'Autofit)
 (vlax-release-object cols)
 (vlax-release-object cell)
 (foreach item     ColHide
   (if    (numberp item)
     (setq item (letter item)))
   (setq cell (vlax-variant-value
        (vlax-invoke-method
          *Sheet#1*
          "Evaluate"
          (strcat item "1:" item "1"))))
   (setq cols (vlax-get-property cell 'Columns))
   (vlax-put-property cols 'hidden 1)
   (vlax-release-object cols)
   (vlax-release-object cell))
 (vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)
 (mapcar 'vlax-release-object
     (list    *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection* *AplExcel*))
 (setq *AplExcel* nil)
 (gc)
 (gc)
 (princ))
(defun C:ATTEXP2XL  (/ blk pat head ss datalist att_list)
 (if (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 66 1)(if (getvar "CTAB")
         (cons 410 (getvar "CTAB")) (cons 67 (- 1 (getvar "TILEMODE")))))))
   (progn
     (foreach item  (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (setq att_list (get-all-atts item))
   (if (null head)
     (setq head (mapcar 'car att_list)))
   (setq datalist (append datalist (list (mapcar 'cdr att_list))))
   )
     (xls datalist head nil nil)
     )
   )
 (princ)
 )
;|=============== Comand AREAS ================================================
Send the Layer, the area, length, color, a hyperlink in corresponding columns Excel.
See also _HYPERLINKOPTIONS |;
(defun c:AREAS    (/ selset *error* retLst lst i UrlDes are)
 (defun *error* (msg) (princ msg) (princ)) ;_ end of defun
 (vl-load-com)
 (if (setq selset (ssget '((0 . "*POLYLINE"))))
   (progn (setq i 1)
      (foreach item  (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
        (if (not (zerop (vla-get-Count (vla-get-Hyperlinks item))))
          (VL-CATCH-ALL-APPLY
        '(lambda () (setq UrlDes (vla-get-URLDescription (vla-item (vla-get-Hyperlinks item) 0)))))
          (setq UrlDes ""))
        (setq lst (list
            (strcat "'" (vla-get-layer item)) ;|Layer"|;
            (rtos (setq are (vla-get-area item)) 2 12) ;|Area|;
            (rtos (vla-get-Length item) 2 12) ;|Length|;
            (vla-get-color item) ;|Color|;
            (if (= UrlDes "")
              ""
              (strcat "'" UrlDes)) ;|Hyperlink|;
            ))
        (setq retLst (append retLst (list lst)))) ;_foreach
      (xls retlst '("Layer" "Area" "Length" "Color" "Hyperlink") nil "from AREAS")))
 (princ))