Jump to content

[Lisp] Detail length counter


ziele_o2k

Recommended Posts

Maybe someone will think this is useful tool - just check gif.

 

https://media.giphy.com/media/l0HU8OGO0xSIui0lq/giphy.gif

 

;; ============================================== ;;
;;                                                ;;
;;   @@@@@ @ @@@@ @    @@@@      @@@   @@  @  @   ;;
;;      @  @ @    @    @        @   @ @  @ @ @    ;;
;;     @   @ @@@@ @    @@@@     @   @   @  @@     ;;
;;    @    @ @    @    @        @   @  @   @ @    ;;
;;   @@@@@ @ @@@@ @@@@ @@@@ @@@  @@@  @@@@ @  @   ;;
;;                                                ;;
;; ============================================== ;;
;; 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
 )
)

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...