[Lisp]细节长度计数器
也许有人会认为这是一个有用的工具-只需检查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(assoc1 _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.lsphttp://forum.cad.pl ;;
;; ================================================================== ;;
;; ================================================================== ;;
;; ================================================================== ;;
;; ================================================================== ;;
; =========================================================================================== ;
; Pobiera punkt od uzytkownika / Gets point from user ;
;Msg - komunikat do wyswietlenia / message to display ;
;Bit - bit sterujacy (patrz initget) / control bit (see initget) ;
;Pt - 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 - zbior wskazan / selection sets ;
;Mode - 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 - liczba do konwersji / conversion number ;
;Unit - 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 = 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 - kolekcja / collection | Model/Paper + Block Object ;
;Pb - punkt bazowy tabeli / table base point ;
;Rows- liczba wierszy / number of rows ;
;Cols- liczba kolumn / number of columns ;
;RowH- wysokosc wierszy / rows height ;
;ColH- 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
)
) 这很有趣，但是你在哪里使用这种尺寸标注？
这种类型会更清楚吗
https://image.ibb.co/cLJdK6/dim_note_sample.jpg
页:
[1]