列表显示文字

wkq004 · 发表于 2016-1-22 19:54:18

(princ "\n文字列表显示,命令TT:\n")
(defun c:tt (/ )
;;文字列表
;;20160122wkq004
(while (not
(setq e (car (entsel "\n选择要列表显示的文字所在的图层:")))
)
)
(setq lst '())
(if (setq
ss (ssget
"x"
(list (cons 0 "TEXT") (cons 8 (cdr (assoc 8 (entget e)))))
)
)
(progn
(repeat (setq n (sslength ss))
(setq e (ssname ss (setq n (1- n))))
(setq str (cdr (assoc 1 (entget e))))
(if (not (member str lst))
(setq lst (cons str lst))
)
)
(princ "\n拾取定位点,表格左上角-->>")
;;;
(setq n (length lst))
(setq strNum "")
(setq h 2.0)
(setq xh t)
(while xh
(setq tmp (grread t 15 1))
(setq mode (car tmp))
(setq val (cadr tmp))
(redraw)
(cond
((= mode 5)
(setq
a (* h 5 3)
b (* (* h 1.5) n)
)
(setq pt1 val
pt2 (mapcar '+ val (list a 0))
pt3 (mapcar '+ val (list a (- b)))
pt4 (mapcar '+ val (list 0 (- b)))
)
(grdraw pt1 pt2 1)
(grdraw pt2 pt3 1)
(grdraw pt3 pt4 1)
(grdraw pt4 pt1 1)
(setq aa
(* 20 (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))))
)
(setq pt1 (mapcar '- val (list aa aa)))
(setq pt3 (mapcar '+ val (list aa aa)))
(setq pt2 (mapcar '+ val (list aa (- aa))))
(setq pt4 (mapcar '+ val (list (- aa) aa)))
(grdraw pt1 pt3 3)
(grdraw pt4 pt2 3)
)
((= mode 3)
(setq pt val)
(princ "\n输入字高默认<2.0>或点取两点指定列表长:")
(setq xh2 t)
(while xh2
(setq tmp (grread t 15 1))
(setq mode2 (car tmp))
(setq val2 (cadr tmp))
(redraw)
(cond
((= mode2 5)
(setq val2 (list (car val) (cadr val2)))
(setq dist (distance val val2))
(setq hh (/ dist (length lst)))
(setq
a (* hh 5 3)
b (* (* hh 1.5) n)
)
(setq pt1 val
pt2 (mapcar '+ val (list a 0))
pt3 (mapcar '+ val (list a (- b)))
pt4 (mapcar '+ val (list 0 (- b)))
)
(grdraw pt1 pt2 1)
(grdraw pt2 pt3 1)
(grdraw pt3 pt4 1)
(grdraw pt4 pt1 1)
)
((= mode2 3)
(setq h hh)
(princ "\n表格高度:")
(princ dist)
(princ " 字高:")
(princ h)
(princ " ")
(setq xh2 nil)
(setq xh nil)
)
((and (= mode2 2) (<= 48 val2 57))
(princ (chr val2))
(setq strNum (strcat strNum (chr val2)))
(setq h 2.0)
(setq a (* h 5)
b (* (* h 1.5) (length lst))
)
)
((and (= mode2 2) (= 8 val2))
(setq strNum (substr strNum 1 (1- (strlen strNum))))
(princ "\n字高:")
(princ strNum)
)
((and (= mode2 2) (or (= 13 val2) (= 32 val2)))
(if (distof strNum)
(setq h (atoi strNum))
(setq h 2.0)
)
(setq xh2 nil)
(setq xh nil)
)
((= mode 25)
(if (distof strNum)
(setq h (atoi strNum))
(setq h 2.0)
)
(setq xh2 nil)
(setq xh nil)
)
(t
(princ "\n")
(princ mode)
(princ " ")
(princ val)
(princ "\n")
)
)
)
)
)
)
;;; (setq tmp (getvar "lastpoint"))
;;; (if (and (setq
;;; h (getdist "\n输入字高默认<2.0>或点取两点指定列表长:")
;;; )
;;; (not (equal tmp (getvar "lastpoint")))
;;; )
;;; (progn
;;; ;;列表长
;;; (setq h (/ h (length lst)))
;;; (princ "\n字高:")
;;; (princ h)
;;; )
;;; (if h
;;; ;;输入了字高
;;; (progn (princ "\n字高:")
;;; (princ h)
;;; )
;;; ;;未输入距离或用鼠标拾取距离,但仅点取了一点
;;; (setq h 2.0)
;;; )
;;; )
;;; (if (and (not pt)
;;; (not (setq pt (getpoint "\n点取放置列表的左上角:")))
;;; )
;;; (progn
;;; (command "zoom" "e")
;;; ;;117.3 [功能] 返回当前视窗左下角和右上角坐标
;;; (setq b (getvar "viewsize")
;;; c (car (getvar "screensize"))
;;; d (cadr (getvar "screensize"))
;;; a (* b (/ c d))
;;; x (setq x (getvar "viewctr"))
;;; x (trans x 1 2)
;;; c (list (- (car x) (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0)
;;; d (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0)
;;; c (trans c 2 1)
;;; d (trans d 2 1)
;;; )
;;; (setq zoom t)
;;; (setq pt d)
;;; )
;;; )
(setq lst (vl-sort lst '<))
(setq i -1)
(setq a (car pt))
(setq b (+ a (* h 5 3)))
(entmake
(list
(cons 0 "LINE")
(cons 8 "表格")
(cons 62 256)
(list 10
a
(setq y (- (cadr pt) (* (setq i (1+ i)) (* h 1.5))))
)
(list 11 b y)
)
)
(repeat (length lst)
(entmake
(list
(cons 0 "LINE")
(cons 8 "表格")
(cons 62 256)
(list 10
a
(setq y (- (cadr pt) (* (setq i (1+ i)) (* h 1.5))))
)
(list 11 b y)
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 "表格")
(cons 62 256)
(cons 1 (itoa i))
(cons 40 h)
(list 10
(+ a (* h 5 0.5))
(+ y (* h 1.5 0.5))
)
(list 11
(+ a (* h 5 0.5))
(+ y (* h 1.5 0.5))
)
(cons 72 1)
(cons 73 2)
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 "表格")
(cons 62 256)
(cons 1 (nth (1- i) lst))
(cons 40 h)
(list 10
(+ a (* h 5 0.5 3))
(+ y (* h 1.5 0.5))
)
(list 11
(+ a (* h 5 0.5 3))
(+ y (* h 1.5 0.5))
)
(cons 72 1)
(cons 73 2)
)
)
)
(setq i -1)
(setq a (cadr pt))
(setq b (- a (* (length lst) (* h 1.5))))
(repeat 4
(entmake
(list (cons 0 "LINE")
(cons 8 "表格")
(cons 62 256)
(list 10
(setq x (+ (car pt) (* (setq i (1+ i)) (* h 5))))
a
)
(list 11 x b)
)
)
)
)
(princ "\n在选定的图层未找到文字.")
)
(princ "\n完成")
;;; (and zoom (command "zoom" "e"))
(princ)
)

(princ "\n文字列表显示,命令TT:\n") 
(defun c:tt (/ ) 
  ;;文字列表 
  ;;20160122wkq004 
  (while (not 
     (setq e (car (entsel "\n选择要列表显示的文字所在的图层:"))) 
   ) 
  ) 
  (setq lst '()) 
  (if (setq 
  ss (ssget 
       "x" 
       (list (cons 0 "TEXT") (cons 8 (cdr (assoc 8 (entget e))))) 
     ) 
      ) 
    (progn 
      (repeat (setq n (sslength ss)) 
  (setq e (ssname ss (setq n (1- n)))) 
  (setq str (cdr (assoc 1 (entget e)))) 
  (if (not (member str lst)) 
    (setq lst (cons str lst)) 
  ) 
      ) 
      (princ "\n拾取定位点,表格左上角-->>") 
;;;       
 
      (setq n (length lst)) 
      (setq strNum "") 
      (setq h 2.0) 
      (setq xh t) 
      (while xh 
  (setq tmp (grread t 15 1)) 
  (setq mode (car tmp)) 
  (setq val (cadr tmp)) 
  (redraw) 
  (cond 
    ((= mode 5) 
     (setq 
       a (* h 5 3) 
       b (* (* h 1.5) n) 
     ) 
     (setq pt1 val 
     pt2 (mapcar '+ val (list a 0)) 
     pt3 (mapcar '+ val (list a (- b))) 
     pt4 (mapcar '+ val (list 0 (- b))) 
     ) 
     (grdraw pt1 pt2 1) 
     (grdraw pt2 pt3 1) 
     (grdraw pt3 pt4 1) 
     (grdraw pt4 pt1 1) 
     (setq aa 
      (* 20 (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))) 
     ) 
     (setq pt1 (mapcar '- val (list aa aa))) 
     (setq pt3 (mapcar '+ val (list aa aa))) 
     (setq pt2 (mapcar '+ val (list aa (- aa)))) 
     (setq pt4 (mapcar '+ val (list (- aa) aa))) 
     (grdraw pt1 pt3 3) 
     (grdraw pt4 pt2 3) 
    ) 
    ((= mode 3) 
     (setq pt val) 
     (princ "\n输入字高默认<2.0>或点取两点指定列表长:") 
      (setq xh2 t) 
      (while xh2 
        (setq tmp (grread t 15 1)) 
        (setq mode2 (car tmp)) 
        (setq val2 (cadr tmp)) 
        (redraw) 
        (cond 
    ((= mode2 5) 
     (setq val2 (list (car val) (cadr val2))) 
     (setq dist (distance val val2)) 
     (setq hh (/ dist (length lst))) 
     (setq 
       a (* hh 5 3) 
       b (* (* hh 1.5) n) 
     ) 
     (setq pt1 val 
           pt2 (mapcar '+ val (list a 0)) 
           pt3 (mapcar '+ val (list a (- b))) 
           pt4 (mapcar '+ val (list 0 (- b))) 
     ) 
     (grdraw pt1 pt2 1) 
     (grdraw pt2 pt3 1) 
     (grdraw pt3 pt4 1) 
     (grdraw pt4 pt1 1) 
    ) 
    ((= mode2 3) 
     (setq h hh) 
     (princ "\n表格高度:") 
     (princ dist) 
     (princ "    字高:") 
     (princ h) 
     (princ "  ") 
     (setq xh2 nil) 
     (setq xh nil) 
    ) 
    ((and (= mode2 2) (<= 48 val2 57)) 
     (princ (chr val2)) 
     (setq strNum (strcat strNum (chr val2))) 
     (setq h 2.0) 
     (setq a (* h 5) 
           b (* (* h 1.5) (length lst)) 
     ) 
    ) 
    ((and (= mode2 2) (= 8 val2)) 
     (setq strNum (substr strNum 1 (1- (strlen strNum)))) 
     (princ "\n字高:") 
     (princ strNum) 
    ) 
    ((and (= mode2 2) (or (= 13 val2) (= 32 val2))) 
     (if (distof strNum) 
       (setq h (atoi strNum)) 
       (setq h 2.0) 
     ) 
     (setq xh2 nil) 
     (setq xh nil) 
    ) 
    ((= mode 25) 
     (if (distof strNum) 
       (setq h (atoi strNum)) 
       (setq h 2.0) 
     ) 
     (setq xh2 nil) 
     (setq xh nil) 
    ) 
    (t 
     (princ "\n") 
     (princ mode) 
     (princ "   ") 
     (princ val) 
     (princ "\n") 
    ) 
        ) 
      ) 
    ) 
  ) 
      ) 
 
;;;      (setq tmp (getvar "lastpoint"))       
;;;      (if (and (setq 
;;;     h (getdist "\n输入字高默认<2.0>或点取两点指定列表长:") 
;;;         ) 
;;;         (not (equal tmp (getvar "lastpoint"))) 
;;;    ) 
;;;  (progn 
;;;    ;;列表长 
;;;    (setq h (/ h (length lst))) 
;;;    (princ "\n字高:") 
;;;    (princ h) 
;;;  ) 
;;;  (if h 
;;;    ;;输入了字高 
;;;    (progn (princ "\n字高:") 
;;;     (princ h) 
;;;    ) 
;;;    ;;未输入距离或用鼠标拾取距离,但仅点取了一点 
;;;    (setq h 2.0) 
;;;  )   
;;;      ) 
 
;;;      (if (and (not pt) 
;;;         (not (setq pt (getpoint "\n点取放置列表的左上角:"))) 
;;;    ) 
;;;  (progn 
;;;    (command "zoom" "e") 
;;;    ;;117.3 [功能] 返回当前视窗左下角和右上角 坐标 
;;;    (setq  b (getvar "viewsize") 
;;;    c (car (getvar "screensize")) 
;;;    d (cadr (getvar "screensize")) 
;;;    a (* b (/ c d)) 
;;;    x (setq x (getvar "viewctr")) 
;;;    x (trans x 1 2) 
;;;    c (list (- (car x) (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0) 
;;;    d (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0) 
;;;    c (trans c 2 1) 
;;;    d (trans d 2 1) 
;;;    ) 
;;;    (setq zoom t) 
;;;    (setq pt d) 
;;;  ) 
;;;      ) 
      (setq lst (vl-sort lst '<)) 
      (setq i -1) 
      (setq a (car pt)) 
      (setq b (+ a (* h 5 3))) 
      (entmake 
  (list 
    (cons 0 "LINE") 
    (cons 8 "表格") 
    (cons 62 256) 
    (list  10 
    a 
    (setq y (- (cadr pt) (* (setq i (1+ i)) (* h 1.5)))) 
    ) 
    (list 11 b y) 
  ) 
      ) 
      (repeat (length lst) 
  (entmake 
    (list 
      (cons 0 "LINE") 
      (cons 8 "表格") 
      (cons 62 256) 
      (list 10 
      a 
      (setq y (- (cadr pt) (* (setq i (1+ i)) (* h 1.5)))) 
      ) 
      (list 11 b y) 
    ) 
  ) 
  (entmake 
    (list 
      (cons 0 "TEXT") 
      (cons 8 "表格") 
      (cons 62 256) 
      (cons 1 (itoa i)) 
      (cons 40 h) 
      (list 10 
      (+ a (* h 5 0.5)) 
      (+ y (* h 1.5 0.5)) 
      ) 
      (list 11 
      (+ a (* h 5 0.5)) 
      (+ y (* h 1.5 0.5)) 
      ) 
      (cons 72 1) 
      (cons 73 2) 
    ) 
  ) 
  (entmake 
    (list 
      (cons 0 "TEXT") 
      (cons 8 "表格") 
      (cons 62 256) 
      (cons 1 (nth (1- i) lst)) 
      (cons 40 h) 
      (list 10 
      (+ a (* h 5 0.5 3)) 
      (+ y (* h 1.5 0.5)) 
      ) 
      (list 11 
      (+ a (* h 5 0.5 3)) 
      (+ y (* h 1.5 0.5)) 
      ) 
      (cons 72 1) 
      (cons 73 2) 
    ) 
  ) 
      ) 
      (setq i -1) 
      (setq a (cadr pt)) 
      (setq b (- a (* (length lst) (* h 1.5)))) 
      (repeat 4 
  (entmake 
    (list  (cons 0 "LINE") 
    (cons 8 "表格") 
    (cons 62 256) 
    (list 10 
          (setq x (+ (car pt) (* (setq i (1+ i)) (* h 5)))) 
          a 
    ) 
    (list 11 x b) 
    ) 
  ) 
      ) 
    ) 
    (princ "\n在选定的图层未找到文字.") 
  ) 
  (princ "\n完成") 
;;;  (and zoom (command "zoom" "e")) 
  (princ) 
)

wkq004 · 发表于 2019-4-23 14:21:44

664571221 发表于 2018-9-25 20:12
能否加一个范围选择

范围选择,能下源码的都会改,个数统计已经有计数了.

664571221 · 发表于 2018-9-25 20:12:39

wkq004 发表于 2016-1-24 23:06

能否加一个范围选择

xiang19751218 · 发表于 2016-1-22 20:56:16

试用了一下，很不错。把TEXT改为*TEXT可统计多行文字。能不能加一项统计数量？

wkq004 · 发表于 2016-1-24 23:06:47

(princ "\n文字列表显示,命令TT:\n")
(defun c:tt (/ delSS)
;;文字列表
;;20160122wkq004
(while (not
(setq e (car (entsel "\n选择要列表显示的文字所在的图层:")))
)
)
(setq lst '())
(if (setq
ss (ssget
"x"
(list (cons 0 "TEXT") (cons 8 (cdr (assoc 8 (entget e)))))
)
)
(progn
(repeat (setq n (sslength ss))
(setq e (ssname ss (setq n (1- n))))
(setq str (cdr (assoc 1 (entget e))))
(if (not (member str lst))
(setq lst (cons str lst))
)
)
(princ "\n拾取表格角点-->>")
(setq n (length lst))
(setq numLst '())
(setq strNum "")
(setq h 2.0)
(setq go t)
(while go
(setq tmp (grread t 15 1))
(setq mode (car tmp))
(setq val (cadr tmp))
(redraw)
(cond
((= mode 5)
(setq
a (* (/ h 1.5) 5 3)
b (* h n)
)
(setq zspt (mapcar '+ val (list (- a) b)))
(FUNredraw zspt a b)
(FUNredrawMouse zspt)
)
((= mode 3)
(setq pto zspt)
(princ "\n输入行高如<2.0>或点取两点指定列表长:")
(setq go2 t)
(while go2
(setq tmp (grread t 15 1))
(setq mode2 (car tmp))
(setq val2 (cadr tmp))
(redraw)
(cond
((= mode2 5)
(setq h
(/ (abs (- (cadr pto) (cadr val2))) (length lst))
)
(setq
a (* (/ h 1.5) 5 3)
b (* h n)
)
(setq tmp (FUNxiangXian pto val2))
(FUNredraw
(setq
pt
(mapcar '+
pto
(list (* a (car tmp)) (* b (cadr tmp)))
)
)
a
b
)
(FUNredrawMouse val2)
)
((= mode2 3)
(setq go2 nil)
(setq go nil)
)
((and (= mode2 2) (<= 46 val2 57) (/= 47 val2))
;;46小数点,47"/"(ascii ".")46 (chr 47)"/"
(setq tmp (FUNinputReal
"行高:"
"输入行高如<2.0>或点取两点指定列表长:"
(list val2)
pto
n
)
)
(if tmp
(setq
pt (cadr tmp)
h (car tmp)
a (* (/ h 1.5) 5 3)
b (* h n)
go2 nil
go nil
)
(setq h 2.0)
)
)
((= mode2 25)
(setq lst nil)
(setq go2 nil)
(setq go nil)
)
)
)
)
((= mode 25)
(setq lst nil)
(setq go nil)
)
)
)
(if lst
(progn
(setq lst (vl-sort lst '<))
(FUNtable pt n 3 a b nil "表格")
(princ "\n完成")
)
(princ "\n放弃")
)
(redraw)
)
(princ "\n在选定的图层未找到文字.")
)
(princ)
)
(defun FUNtableText (lst pt row column aa bb cell lay /)
(setq i 0)
(repeat row
(entmake
(list
(cons 0 "TEXT")
(cons 8 lay)
(cons 62 256)
(cons 1 (itoa (1+ i)))
(cons 40 (/ h 1.5))
(cons 10
(setq
tmp
(list (+ x (* w 0.5))
(setq yy (- y (* (setq i (1+ i)) h) (* h -0.5)))
)
)
)
(cons 11 tmp)
(cons 72 1)
(cons 73 2)
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 lay)
(cons 62 256)
(cons 1 (nth (1- i) lst))
(cons 40 h)
(cons 40 (/ h 1.5))
(cons 10
(setq tmp (list (+ x (* w 1.5))
yy
)
)
)
(cons 11 tmp)
(cons 72 1)
(cons 73 2)
)
)
)
)
(defun FUNxiangXian (pto pt / ang a b)
;;以pto为参照原点,返回pt所在的象限,及以pto在左上角时符号是正为参照,将pto改成左上角时xy的改正值
(setq ang (angle pto pt))
(cond
((<= 0 ang (/ pi 2))
(setq
a 0
b 1
c 1
)
) ;_1象限
((<= (/ pi 2) ang pi)
(setq
a -1
b 1
c 2
)
) ;_2象限
((<= pi ang (* pi 1.5))
(setq
a -1
b 0
c 3
)
) ;_3象限
((<= (* pi 1.5) ang (* pi 2))
(setq
a 0
b 0
c 4
)
) ;_4象限
)
(list a b c)
)
(defun FUNtable (pt row column aa bb cell lay /)
;;绘制直线表格
(progn
(if cell
(setq w (abs aa)
h (abs bb)
a (* w column)
b (* h row)
)
(setq a (abs aa)
b (abs bb)
w (/ a column)
h (/ b row)
)
)
(setq x (car pt))
(setq y (cadr pt))
(cond ((and (> aa 0) (< bb 0)) ;_1象限
(setq pt (list x (+ y b)))
)
((and (< aa 0) (< bb 0)) ;_2象限
(setq pt (list (- x a) (+ y b)))
)
((and (< aa 0) (> bb 0)) ;_3象限
(setq pt (list (- x a) y))
)
((and (> aa 0) (> bb 0)) ;_4象限
(setq pt pt)
)
)
(setq x (car pt))
(setq y (cadr pt))
(setq xx (+ x a))
(setq i -1)
(repeat (1+ row)
(entmake
(list
(cons 0 "LINE")
(cons 8 lay)
(cons 62 256)
(list 10
x
(setq yy (- y (* (setq i (1+ i)) h)))
)
(list 11 xx yy)
)
)
)
(setq i 0)
(repeat row
(entmake
(list
(cons 0 "TEXT")
(cons 8 lay)
(cons 62 256)
(cons 1 (itoa (1+ i)))
(cons 40 (/ h 1.5))
(cons 10
(setq
tmp
(list (+ x (* w 0.5))
(setq yy (- y (* (setq i (1+ i)) h) (* h -0.5)))
)
)
)
(cons 11 tmp)
(cons 72 1)
(cons 73 2)
)
)
(entmake
(list
(cons 0 "TEXT")
(cons 8 lay)
(cons 62 256)
(cons 1 (nth (1- i) lst))
(cons 40 h)
(cons 40 (/ h 1.5))
(cons 10
(setq tmp (list (+ x (* w 1.5))
yy
)
)
)
(cons 11 tmp)
(cons 72 1)
(cons 73 2)
)
)
)
(setq i -1)
(setq yy (- y b))
(repeat (1+ column)
(entmake
(list
(cons 0 "LINE")
(cons 8 lay)
(cons 62 256)
(list 10
(setq xx (+ x (* (setq i (1+ i)) w)))
y
)
(list 11 xx yy)
)
)
)
)
)
(defun FUNinputReal (str restr lst pto n / A AA B
GO H MODE PT1 PT2 PT3 PT4 REAL TMP VAL
ptxx
)
;;输入实数20081128zml84
;;http://bbs.mjtd.com/thread-72167-1-1.html
(vl-load-com)
(setvar "CMDECHO" 0)
(princ "\n")
(princ (strcat "\r" str))
(princ (vl-list->string (reverse lst)))
(defun FUNtmp ()
;;
(setq h (read (vl-list->string (reverse lst))))
(setq
a (* (/ h 1.5) 5 3)
b (* h n)
)
(setq ptxx (FUNxiangXian pto pt2))
(FunRedrawRectang
(setq
pt
(mapcar '+
pto
(list (* a (car ptxx)) (* b (cadr ptxx)))
)
)
a
b
)
(FUNredrawMouse pt2)
;;; (FUNredrawMouse (mapcar '+ pt (list a (- b))))
)
;;; (if lst
;;; (progn
;;; (princ (vl-list->string (reverse lst)))
;;; (setq val (cadr (grread t 1 1)))
;;; (FUNtmp)
;;; )
;;; )
(setq real nil)
(setq window (getvar "VIEWSIZE"))
(setq go T)
(while go
(setq tmp (grread t 15 1)
mode (car tmp)
val (cadr tmp)
)
(redraw)
(cond ((and (= mode 5)
(setq pt2 val)
(or
(FUNredrawMouse pt2)
(not (equal ptxx (setq ptxx (FUNxiangXian pto pt2))))
(not (equal window (setq window (getvar "VIEWSIZE"))))
)
)
(FUNtmp)
)
((and (= mode 2)
(/= val 47)
(<= 46 val 57)
)
(setq lst (cons val lst))
(princ (strcat "\r"
str
(vl-list->string (reverse lst))
" "
)
)
(FUNtmp)
)
((or
(and (= mode 2)
(or (= val 13) ;_回车键
(= val 32) ;_空格
)
)
(= mode 3) ;_左键
)
(if lst
(progn
(setq real (read (vl-list->string (reverse lst))))
;;; (princ (strcat "\n" str (vl-list->string (reverse lst))))
(setq lst '())
)
)
(setq go nil)
)
((and (= mode 2)
(= val 8) ;_退格键
)
(setq lst (cdr lst))
(princ (strcat "\r"
str
(vl-list->string (reverse lst))
" "
)
)
(if lst
(FUNtmp)
(progn
(princ "\n")
(princ restr)
(setq go nil)
)
)
)
((= mode 25)
(princ "\n")
(princ restr)
(setq go nil)
)
)
)
(if (and delSS (> (setq n (sslength delSS)) 0))
;;; (command "erase" delSS "")
(progn (repeat n
(if (not (vlax-erased-p
(vlax-ename->vla-object
(setq tmp (ssname delSS (setq n (1- n))))
)
)
)
(entdel tmp)
)
)
(setq
delSS (ssadd)
)
)
(setq delSS (ssadd))
)
(if real
(list real pt)
nil
)
)
(defun FunRedrawRectang (pt a b / n A B tmp PT1 PT2 PT3 PT4)
;;以左上角为基点绘制矩形
(if (and delSS (> (setq n (sslength delSS)) 0))
;;; (command "erase" delSS "")
(progn (repeat n
(if (not (vlax-erased-p
(vlax-ename->vla-object
(setq tmp (ssname delSS (setq n (1- n))))
)
)
)
(entdel tmp)
)
)
(setq delSS (ssadd))
)
(setq delSS (ssadd))
)
(setq pt1 pt
pt2 (mapcar '+ pt (list a 0))
pt3 (mapcar '+ pt (list a (- b)))
pt4 (mapcar '+ pt (list 0 (- b)))
)
(ssadd (FunEntmakeLine pt1 pt2 "外框") delSS)
(ssadd (FunEntmakeLine pt2 pt3 "外框") delSS)
(ssadd (FunEntmakeLine pt3 pt4 "外框") delSS)
(ssadd (FunEntmakeLine pt4 pt1 "外框") delSS)
)
(defun FunEntmakeLine (a b lay /)
(if (entmake
(list (cons 0 "LINE")
(cons 8 lay)
(cons 62 1)
(cons 10 a)
(cons 11 b)
)
)
(entlast)
nil
)
)
(defun FUNredraw (pt a b / A B tmp PT1 PT2 PT3 PT4)
;;以左上角为基点绘制矩形
(redraw)
(setq pt1 pt
pt2 (mapcar '+ pt (list a 0))
pt3 (mapcar '+ pt (list a (- b)))
pt4 (mapcar '+ pt (list 0 (- b)))
)
(grdraw pt1 pt2 1)
(grdraw pt2 pt3 1)
(grdraw pt3 pt4 1)
(grdraw pt4 pt1 1)
)
(defun FUNredrawMouse (pt / A B tmp PT1 PT2 PT3 PT4)
(setq tmp
(* 20 (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))))
)
(setq pt1 (mapcar '- pt (list tmp tmp)))
(setq pt3 (mapcar '+ pt (list tmp tmp)))
(setq pt2 (mapcar '+ pt (list tmp (- tmp))))
(setq pt4 (mapcar '+ pt (list (- tmp) tmp)))
(grdraw pt1 pt3 3)
(grdraw pt4 pt2 3)
)

(princ "\n文字列表显示,命令TT:\n") 
(defun c:tt (/ delSS) 
  ;;文字列表 
  ;;20160122wkq004 
  (while (not 
           (setq e (car (entsel "\n选择要列表显示的文字所在的图层:"))) 
         ) 
  ) 
  (setq lst '()) 
  (if (setq 
        ss (ssget 
             "x" 
             (list (cons 0 "TEXT") (cons 8 (cdr (assoc 8 (entget e))))) 
           ) 
      ) 
    (progn 
      (repeat (setq n (sslength ss)) 
        (setq e (ssname ss (setq n (1- n)))) 
        (setq str (cdr (assoc 1 (entget e)))) 
        (if (not (member str lst)) 
          (setq lst (cons str lst)) 
        ) 
      ) 
      (princ "\n拾取表格角点-->>") 
      (setq n (length lst)) 
      (setq numLst '()) 
      (setq strNum "") 
      (setq h 2.0) 
      (setq go t) 
      (while go 
        (setq tmp (grread t 15 1)) 
        (setq mode (car tmp)) 
        (setq val (cadr tmp)) 
        (redraw) 
        (cond 
          ((= mode 5) 
           (setq 
             a (* (/ h 1.5) 5 3) 
             b (* h n) 
           ) 
           (setq zspt (mapcar '+ val (list (- a) b))) 
           (FUNredraw zspt a b) 
           (FUNredrawMouse zspt) 
          ) 
          ((= mode 3) 
           (setq pto zspt) 
           (princ "\n输入行高如<2.0>或点取两点指定列表长:") 
           (setq go2 t) 
           (while go2 
             (setq tmp (grread t 15 1)) 
             (setq mode2 (car tmp)) 
             (setq val2 (cadr tmp)) 
             (redraw) 
             (cond 
               ((= mode2 5) 
                (setq h 
                       (/ (abs (- (cadr pto) (cadr val2))) (length lst)) 
                ) 
                (setq 
                  a (* (/ h 1.5) 5 3) 
                  b (* h n) 
                ) 
                (setq tmp (FUNxiangXian pto val2)) 
                (FUNredraw 
                  (setq 
                    pt 
                     (mapcar '+ 
                             pto 
                             (list (* a (car tmp)) (* b (cadr tmp))) 
                     ) 
                  ) 
                  a 
                  b 
                ) 
                (FUNredrawMouse val2) 
               ) 
               ((= mode2 3) 
                (setq go2 nil) 
                (setq go nil) 
               ) 
               ((and (= mode2 2) (<= 46 val2 57) (/= 47 val2)) 
                ;;46小数点,47"/"(ascii ".")46  (chr 47)"/" 
                (setq tmp (FUNinputReal 
                            "行高:" 
                            "输入行高如<2.0>或点取两点指定列表长:" 
                            (list val2) 
                            pto 
                            n 
                          ) 
                ) 
                (if tmp 
                  (setq 
                    pt        (cadr tmp) 
                    h        (car tmp) 
                    a        (* (/ h 1.5) 5 3) 
                    b        (* h n) 
                    go2        nil 
                    go        nil 
                  ) 
                  (setq h 2.0) 
                ) 
               ) 
               ((= mode2 25) 
                (setq lst nil) 
                (setq go2 nil) 
                (setq go nil) 
               ) 
             ) 
           ) 
          ) 
          ((= mode 25) 
           (setq lst nil) 
           (setq go nil) 
          ) 
        ) 
      ) 
      (if lst 
        (progn 
          (setq lst (vl-sort lst '<)) 
          (FUNtable pt n 3 a b nil "表格") 
          (princ "\n完成") 
        ) 
        (princ "\n放弃") 
      ) 
      (redraw) 
    ) 
    (princ "\n在选定的图层未找到文字.") 
  ) 
  (princ) 
) 
(defun FUNtableText (lst pt row column aa bb cell lay /) 
  (setq i 0) 
  (repeat row 
    (entmake 
      (list 
        (cons 0 "TEXT") 
        (cons 8 lay) 
        (cons 62 256) 
        (cons 1 (itoa (1+ i))) 
        (cons 40 (/ h 1.5)) 
        (cons 10 
              (setq 
                tmp 
                 (list (+ x (* w 0.5)) 
                       (setq yy (- y (* (setq i (1+ i)) h) (* h -0.5))) 
                 ) 
              ) 
        ) 
        (cons 11 tmp) 
        (cons 72 1) 
        (cons 73 2) 
      ) 
    ) 
    (entmake 
      (list 
        (cons 0 "TEXT") 
        (cons 8 lay) 
        (cons 62 256) 
        (cons 1 (nth (1- i) lst)) 
        (cons 40 h) 
        (cons 40 (/ h 1.5)) 
        (cons 10 
              (setq tmp        (list (+ x (* w 1.5)) 
                              yy 
                        ) 
              ) 
        ) 
        (cons 11 tmp) 
        (cons 72 1) 
        (cons 73 2) 
      ) 
    ) 
  ) 
) 
(defun FUNxiangXian (pto pt / ang a b) 
  ;;以pto为参照原点,返回pt所在的象限,及以pto在左上角时符号是正为参照,将pto改成左上角时xy的改正值 
  (setq ang (angle pto pt)) 
  (cond 
    ((<= 0 ang (/ pi 2)) 
     (setq 
       a 0 
       b 1 
       c 1 
     ) 
    ) ;_1象限 
    ((<= (/ pi 2) ang pi) 
     (setq 
       a -1 
       b 1 
       c 2 
     ) 
    ) ;_2象限 
    ((<= pi ang (* pi 1.5)) 
     (setq 
       a -1 
       b 0 
       c 3 
     ) 
    ) ;_3象限 
    ((<= (* pi 1.5) ang (* pi 2)) 
     (setq 
       a 0 
       b 0 
       c 4 
     ) 
    ) ;_4象限 
  ) 
  (list a b c) 
) 
(defun FUNtable        (pt row column aa bb cell lay /) 
  ;;绘制直线表格 
  (progn 
    (if        cell 
      (setq w (abs aa) 
            h (abs bb) 
            a (* w column) 
            b (* h row) 
      ) 
      (setq a (abs aa) 
            b (abs bb) 
            w (/ a column) 
            h (/ b row) 
      ) 
    ) 
    (setq x (car pt)) 
    (setq y (cadr pt)) 
    (cond ((and (> aa 0) (< bb 0)) ;_1象限 
           (setq pt (list x (+ y b))) 
          ) 
          ((and (< aa 0) (< bb 0)) ;_2象限 
           (setq pt (list (- x a) (+ y b))) 
          ) 
          ((and (< aa 0) (> bb 0)) ;_3象限 
           (setq pt (list (- x a) y)) 
          ) 
          ((and (> aa 0) (> bb 0)) ;_4象限 
           (setq pt pt) 
          ) 
    ) 
    (setq x (car pt)) 
    (setq y (cadr pt)) 
    (setq xx (+ x a)) 
    (setq i -1) 
    (repeat (1+ row) 
      (entmake 
        (list 
          (cons 0 "LINE") 
          (cons 8 lay) 
          (cons 62 256) 
          (list        10 
                x 
                (setq yy (- y (* (setq i (1+ i)) h))) 
          ) 
          (list 11 xx yy) 
        ) 
      ) 
    ) 
    (setq i 0) 
    (repeat row 
      (entmake 
        (list 
          (cons 0 "TEXT") 
          (cons 8 lay) 
          (cons 62 256) 
          (cons 1 (itoa (1+ i))) 
          (cons 40 (/ h 1.5)) 
          (cons        10 
                (setq 
                  tmp 
                   (list (+ x (* w 0.5)) 
                         (setq yy (- y (* (setq i (1+ i)) h) (* h -0.5))) 
                   ) 
                ) 
          ) 
          (cons 11 tmp) 
          (cons 72 1) 
          (cons 73 2) 
        ) 
      ) 
      (entmake 
        (list 
          (cons 0 "TEXT") 
          (cons 8 lay) 
          (cons 62 256) 
          (cons 1 (nth (1- i) lst)) 
          (cons 40 h) 
          (cons 40 (/ h 1.5)) 
          (cons        10 
                (setq tmp (list        (+ x (* w 1.5)) 
                                yy 
                          ) 
                ) 
          ) 
          (cons 11 tmp) 
          (cons 72 1) 
          (cons 73 2) 
        ) 
      ) 
    ) 
    (setq i -1) 
    (setq yy (- y b)) 
    (repeat (1+ column) 
      (entmake 
        (list 
          (cons 0 "LINE") 
          (cons 8 lay) 
          (cons 62 256) 
          (list        10 
                (setq xx (+ x (* (setq i (1+ i)) w))) 
                y 
          ) 
          (list 11 xx yy) 
        ) 
      ) 
    ) 
  ) 
) 
(defun FUNinputReal (str  restr            lst         pto  n           /        A    AA          B 
                     GO          H    MODE PT1         PT2  PT3  PT4        REAL TMP  VAL 
                     ptxx 
                    ) 
  ;;输入实数20081128zml84 
  ;;<a href="http://bbs.mjtd.com/thread-72167-1-1.html" target="_blank">http://bbs.mjtd.com/thread-72167-1-1.html</a> 
  (vl-load-com) 
  (setvar "CMDECHO" 0) 
  (princ "\n") 
  (princ (strcat "\r" str)) 
  (princ (vl-list->string (reverse lst))) 
  (defun FUNtmp        () 
    ;; 
    (setq h (read (vl-list->string (reverse lst)))) 
 
    (setq 
      a        (* (/ h 1.5) 5 3) 
      b        (* h n) 
    ) 
    (setq ptxx (FUNxiangXian pto pt2)) 
    (FunRedrawRectang 
      (setq 
        pt 
         (mapcar '+ 
                 pto 
                 (list (* a (car ptxx)) (* b (cadr ptxx))) 
         ) 
      ) 
      a 
      b 
    ) 
    (FUNredrawMouse pt2) 
;;;    (FUNredrawMouse (mapcar '+ pt (list a (- b)))) 
  ) 
;;;  (if lst 
;;;    (progn 
;;;      (princ (vl-list->string (reverse lst))) 
;;;      (setq val (cadr (grread t 1 1))) 
;;;      (FUNtmp) 
;;;    ) 
;;;  ) 
  (setq real nil) 
  (setq window (getvar "VIEWSIZE")) 
  (setq go T) 
  (while go 
    (setq tmp  (grread t 15 1) 
          mode (car tmp) 
          val  (cadr tmp) 
    ) 
    (redraw) 
    (cond ((and        (= mode 5) 
                (setq pt2 val) 
                (or 
                  (FUNredrawMouse pt2) 
                  (not (equal ptxx (setq ptxx (FUNxiangXian pto pt2)))) 
                  (not (equal window (setq window (getvar "VIEWSIZE")))) 
                ) 
           ) 
           (FUNtmp) 
          ) 
          ((and        (= mode 2) 
                (/= val 47) 
                (<= 46 val 57) 
           ) 
           (setq lst (cons val lst)) 
           (princ (strcat "\r" 
                          str 
                          (vl-list->string (reverse lst)) 
                          "               " 
                  ) 
           ) 
           (FUNtmp) 
          ) 
          ((or 
             (and (= mode 2) 
                  (or (= val 13) ;_回车键 
                      (= val 32) ;_空格 
                  ) 
             ) 
             (= mode 3) ;_左键 
           ) 
           (if lst 
             (progn 
               (setq real (read (vl-list->string (reverse lst)))) 
;;;               (princ (strcat "\n" str (vl-list->string (reverse lst)))) 
               (setq lst '()) 
             ) 
           ) 
           (setq go nil) 
          ) 
          ((and        (= mode 2) 
                (= val 8) ;_退格键 
           ) 
           (setq lst (cdr lst)) 
           (princ (strcat "\r" 
                          str 
                          (vl-list->string (reverse lst)) 
                          "               " 
                  ) 
           ) 
           (if lst 
             (FUNtmp) 
             (progn 
               (princ "\n") 
               (princ restr) 
               (setq go nil) 
             ) 
           ) 
          ) 
          ((= mode 25) 
           (princ "\n") 
           (princ restr) 
           (setq go nil) 
          ) 
    ) 
  ) 
  (if (and delSS (> (setq n (sslength delSS)) 0)) 
;;;    (command "erase" delSS "") 
    (progn (repeat n 
             (if (not (vlax-erased-p 
                        (vlax-ename->vla-object 
                          (setq tmp (ssname delSS (setq n (1- n)))) 
                        ) 
                      ) 
                 ) 
               (entdel tmp) 
             ) 
           ) 
           (setq 
             delSS (ssadd) 
           ) 
    ) 
    (setq delSS (ssadd)) 
  ) 
  (if real 
    (list real pt) 
    nil 
  ) 
) 
 
(defun FunRedrawRectang        (pt a b / n A B tmp PT1 PT2 PT3 PT4) 
  ;;以左上角为基点绘制矩形 
  (if (and delSS (> (setq n (sslength delSS)) 0)) 
;;;    (command "erase" delSS "") 
    (progn (repeat n 
             (if (not (vlax-erased-p 
                        (vlax-ename->vla-object 
                          (setq tmp (ssname delSS (setq n (1- n)))) 
                        ) 
                      ) 
                 ) 
               (entdel tmp) 
             ) 
           ) 
           (setq delSS (ssadd)) 
    ) 
    (setq delSS (ssadd)) 
  ) 
  (setq        pt1 pt 
        pt2 (mapcar '+ pt (list a 0)) 
        pt3 (mapcar '+ pt (list a (- b))) 
        pt4 (mapcar '+ pt (list 0 (- b))) 
  ) 
  (ssadd (FunEntmakeLine pt1 pt2 "外框") delSS) 
  (ssadd (FunEntmakeLine pt2 pt3 "外框") delSS) 
  (ssadd (FunEntmakeLine pt3 pt4 "外框") delSS) 
  (ssadd (FunEntmakeLine pt4 pt1 "外框") delSS) 
) 
 
(defun FunEntmakeLine (a b lay /) 
  (if (entmake 
        (list (cons 0 "LINE") 
              (cons 8 lay) 
              (cons 62 1) 
              (cons 10 a) 
              (cons 11 b) 
        ) 
      ) 
    (entlast) 
    nil 
  ) 
) 
 
(defun FUNredraw (pt a b / A B tmp PT1 PT2 PT3 PT4) 
  ;;以左上角为基点绘制矩形 
  (redraw) 
  (setq        pt1 pt 
        pt2 (mapcar '+ pt (list a 0)) 
        pt3 (mapcar '+ pt (list a (- b))) 
        pt4 (mapcar '+ pt (list 0 (- b))) 
  ) 
  (grdraw pt1 pt2 1) 
  (grdraw pt2 pt3 1) 
  (grdraw pt3 pt4 1) 
  (grdraw pt4 pt1 1) 
) 
 
(defun FUNredrawMouse (pt / A B tmp PT1 PT2 PT3 PT4) 
  (setq        tmp 
         (* 20 (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))) 
  ) 
  (setq pt1 (mapcar '- pt (list tmp tmp))) 
  (setq pt3 (mapcar '+ pt (list tmp tmp))) 
  (setq pt2 (mapcar '+ pt (list tmp (- tmp)))) 
  (setq pt4 (mapcar '+ pt (list (- tmp) tmp))) 
  (grdraw pt1 pt3 3) 
  (grdraw pt4 pt2 3) 
)

hao3ren · 发表于 2016-1-25 10:38:48

建议文字之间连线，容易查找

vladimirputin · 发表于 2016-10-23 13:56:21

非常实用的程序，谢谢楼主分享。

664571221 · 发表于 2018-8-28 15:59:53

你好能否价格个数统计和范围选择

903590625 · 发表于 2018-8-28 16:00:58

感谢楼主分享

903590625 · 发表于 2018-8-28 16:01:04

感谢楼主分享

账号		自动登录	找回密码
密码			注册

[源码] 列表显示文字

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

浏览过的版块