[编程交流] [Lisp]细节长度计数器

;; ============================================== ;;
;;                                                ;;
;;   @@@@@ @ @@@@ @    @@@@      @@@   @@  @  @   ;;
;;      @  @ @    @    @        @   @ @  @ @ @    ;;
;;     @   @ @@@@ @    @@@@     @   @   @  @@     ;;
;;    @    @ @    @    @        @   @  @   @ @    ;;
;;   @@@@@ @ @@@@ @@@@ @@@@ @@@  @@@  @@@@ @  @   ;;
;;                                                ;;
;; ============================================== ;;
;; 22:50 2018-01-11 © ziele_o2k                   ;;
;; ============================================== ;;
;; some code copied from Lee Mac's Block Counter  ;;
;; http://www.lee-mac.com/blockcounter.html       ;;
;; ============================================== ;;
(defun c:detsum ( /  pz:sub _pt _ss _enx _k _v _res _tab _row _hgt _wth _tg1 _tg2 _tg3)
 (defun pz:sub ( @key @val @lst / _itm )
   (if (setq _itm (assoc @key @lst))
     (subst (cons @key (+ @val (cdr _itm))) _itm @lst)
     (cons  (cons @key @val) @lst)
   )
 )
 (if
   (and
     (setq _ss (ssget '((0 . "DIM*"))))
     (setq _pt (cd:USR_GetPoint "\nTable insertion point: " 1 nil))
   )
   (progn
     (foreach %1 (cd:SSX_Convert _ss 0)
       (setq 
         _enx  (entget %1)
         _k    (cdr(assoc  1 _enx))
         _v    (cdr(assoc 42 _enx))
         _res  (pz:sub _k _v _res)
       )
     )
     (setq _res
       (vl-sort
         (mapcar
          '(lambda (%)
             (list (car %) (cd:CON_Real2Str (cdr %) 2 1))
           )
           _res
         )
         '(eval (list 'lambda '( a b ) (list '< '(strcase (car a)) '(strcase (car b)))))
       )
     )
     (setq _hgt
       (vla-gettextheight
         (vla-item
           (vla-item (vla-get-dictionaries (cd:ACX_ADoc)) "acad_tablestyle")
           (getvar 'ctablestyle)
         )
         acdatarow
       )
       _tg1 "Detail sum"
       _tg2 "Detail name"
       _tg3 "Sum"
     )
     (setq _tab 
       (cd:ACX_AddTable 
         (cd:ACX_ASpace) _pt 
         (+ (length _res) 2) 
         2 
         (* 2 _hgt) 
         (* _hgt
           (max
             (apply 'max
               (mapcar 'strlen
                 (append
                   (list _tg2)
                   (list _tg3)
                   (apply 'append _res)
                 )
               )
             )
             (/ (strlen _tg1) 2)
           )
         )
       )
     )
     (vla-setText _tab 0 0 _tg1)
     (vla-setText _tab 1 0 _tg2)
     (vla-setText _tab 1 1 _tg3)
     (setq _row 2)
     (foreach %1 _res
       (vla-setText _tab _row 0 (car %1))
       (vla-setText _tab _row 1 (cadr %1))
       (setq _row (1+ _row))
     )
   )
 )
 (princ)
)
;; ================================================================== ;;
;; ================================================================== ;;
;; ================================================================== ;;
;; ================================================================== ;;
;; Subfunctions form CADPL-Pack-v1.lsp  http://forum.cad.pl           ;;
;; ================================================================== ;;
;; ================================================================== ;;
;; ================================================================== ;;
;; ================================================================== ;;
; =========================================================================================== ;
; Pobiera punkt od uzytkownika / Gets point from user                                         ;
;  Msg [sTR]      - komunikat do wyswietlenia / message to display                            ;
;  Bit [iNT/nil]  - bit sterujacy (patrz initget) / control bit (see initget)                 ;
;  Pt  [list/nil] - punkt bazowy / base point                                                 ;
; ------------------------------------------------------------------------------------------- ;
; (cd:USR_GetPoint "\nWskaz punkt: " 1 nil)                                                   ;
; (cd:USR_GetPoint "\nWskaz drugi punkt: " 32 '(5 10 0))                                      ;
; =========================================================================================== ;
(defun cd:USR_GetPoint (Msg Bit Pt / res)
 (if Bit (initget Bit))
 (if
   (listp
     (setq res
       (vl-catch-all-apply
         (quote getpoint)
         (if Pt
           (list Pt Msg)
           (list Msg)
         )
       )
     )
   )
   res
 )
)
; =========================================================================================== ;
; 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
     )
   )
 )
)
; =========================================================================================== ;
; Konwertuje liczbe na lancuch tekstowy / Converts number to a string                         ;
;  Val  [REAL/INT] - liczba do konwersji / conversion number                                  ;
;  Unit [iNT/nil]  - jednostki wyjsciowe / output unit                                        ;
;                    nil = domyslne / default | (getvar "LUNITS")                             ;
;                    1   = naukowe / scientific                                               ;
;                    2   = dziesietne / decimal                                               ;
;                    3   = inzynierskie / engineering                                         ;
;                    4   = architektoniczne / architectural                                   ;
;                    5   = ulamkowe / fractional                                              ;
;  Prec [iNT/nil]  - INT = liczba miejsc po przecinku / number of decimal places              ;
;                    nil = domyslna / default | (getvar "LUPREC")                             ;
; ------------------------------------------------------------------------------------------- ;
; (cd:CON_Real2Str 12 2 4)                                                                    ;
; =========================================================================================== ;
(defun cd:CON_Real2Str (Val Unit Prec / DMZ res)
 (setq DMZ (getvar "DIMZIN"))
 (setvar "DIMZIN"
   (if (not (member (getvar "LUNITS") (list 4 5)))
     (logand DMZ (~ ) 0
   )
 )
 (setq res
   (rtos
     Val
     (if (and Unit (member Unit (list 1 2 3 4 5))) 
       Unit
       (getvar "LUNITS")
     )
     (if Prec Prec (getvar "LUPREC"))
   )
 )
 (setvar "DIMZIN" DMZ)
 res
)
; =========================================================================================== ;
; Aktywny dokument / Active document                                                          ;
; =========================================================================================== ;
(defun cd:ACX_ADoc ()
 (or
   *cd-ActiveDocument*
   (setq *cd-ActiveDocument*
     (vla-get-ActiveDocument (vlax-get-acad-object))
   )
 )
 *cd-ActiveDocument*
)
; =========================================================================================== ;
; Aktywny obszar / Active space                                                               ;
; =========================================================================================== ;
(defun cd:ACX_ASpace ()
 (if (= (getvar "CVPORT") 1)
   (vla-item (cd:ACX_Blocks) "*Paper_Space")
   (cd:ACX_Model)
 )
)
; =========================================================================================== ;
; Kolekcja Blocks / Blocks collection                                                         ;
; =========================================================================================== ;
(defun cd:ACX_Blocks ()
 (or
   *cd-Blocks*
   (setq *cd-Blocks* (vla-get-blocks (cd:ACX_ADoc)))
 )
 *cd-Blocks*
)
; =========================================================================================== ;
; Tworzy obiekt typu ACAD_TABLE / Creates a ACAD_TABLE object                                 ;
;  Space [VLA-Object]  - kolekcja / collection | Model/Paper + Block Object                   ;
;  Pb    [list] - punkt bazowy tabeli / table base point                                      ;
;  Rows  [iNT]  - liczba wierszy / number of rows                                             ;
;  Cols  [iNT]  - liczba kolumn / number of columns                                           ;
;  RowH  [iNT]  - wysokosc wierszy / rows height                                              ;
;  ColH  [iNT]  - szerokosc kolumn / columns height                                           ;
; ------------------------------------------------------------------------------------------- ;
; (cd:ACX_AddTable (cd:ACX_ASpace) (getpoint) 5 5 10 30)                                      ;
; =========================================================================================== ;
(defun cd:ACX_AddTable (Space Pb Rows Cols RowH ColH)
 (vla-AddTable
    Space
    (vlax-3d-point (trans Pb 1 0))
    Rows
    Cols
    RowH
    ColH
 )
)