快速找出所含文字并用圆形云线框出来

nishuihanjian · 发表于 2017-8-7 12:06:52

求大神写个程序：快速找出所含的指定文字，有几处找出几处并在所有含有此文字的地方用云线框出来，云线颜色为紫色，云线自动按全局比例调整，云线范围根据字的大小的5倍确定。

springwillow · 发表于 2017-8-8 15:17:57

收集的功能，跟楼主要求类似，不过不是画云线，是画圆。很久不玩lisp了

(defun c:czwz ()
(setvar "cmdecho" 0)
(command "undo" "be")
(setq stxt (getstring "\n输入或点取要查找的文字<点取> :"))
(if (and (= stxt "")
(setq s1 (entsel "\n选择要查找的文字 :"))
(setq ent (entget(car s1)))
(= (cdr(assoc 0 ent)) "TEXT"))
(setq stxt (cdr(assoc 1 (entget(car s1)))))
)
(if (setq ss (ssget (list '(0 . "TEXT") (cons 1 (strcat "*" stxt "*"))))) (progn
(setq i 0)
(repeat (sslength ss)
(setq en (ssname ss i))
(vla-getboundingbox(vlax-ename->vla-object en) 'minp 'maxp)
(setq minp (vlax-safearray->list minp)
maxp (vlax-safearray->list maxp))
(setq pt (polar minp (angle minp maxp) (/ (distance minp maxp) 2)))
(entmake (list '(0 . "CIRCLE") (cons 8 "FindText")(cons 62 6)(cons 10 pt) (cons 40 (/ (distance minp maxp) 2))))
(setq i (1+ i))
)
(princ)
))
(command "undo" "end")
(setvar "CMDECHO" 1)
(princ)
)

(defun c:czwz () 
(setvar "cmdecho" 0) 
(command "undo" "be") 
(setq stxt (getstring "\n输入或点取要查找的文字<点取> :")) 
(if (and (= stxt "") 
          (setq s1 (entsel "\n选择要查找的文字 :")) 
          (setq ent (entget(car s1))) 
          (= (cdr(assoc 0 ent)) "TEXT")) 
  (setq stxt (cdr(assoc 1 (entget(car s1))))) 
) 
(if (setq ss (ssget (list '(0 . "TEXT") (cons 1 (strcat "*" stxt "*"))))) (progn 
  (setq i 0) 
  (repeat (sslength ss) 
   (setq en (ssname ss i)) 
   (vla-getboundingbox(vlax-ename->vla-object en) 'minp 'maxp) 
   (setq minp (vlax-safearray->list minp) 
         maxp (vlax-safearray->list maxp)) 
   (setq pt (polar minp (angle minp maxp) (/ (distance minp maxp) 2))) 
   (entmake (list '(0 . "CIRCLE") (cons 8 "FindText")(cons 62 6)(cons 10 pt) (cons 40 (/ (distance minp maxp) 2)))) 
   (setq i (1+ i)) 
  ) 
  (princ) 
)) 
(command "undo" "end") 
(setvar "CMDECHO" 1) 
(princ) 
)

永不言弃 · 发表于 2017-8-8 09:38:37

我有一个这样的

jun353835273 · 发表于 2017-8-9 17:21:07

(defun c:czwz1 ( / EN ENT GETPT I MAXP MINP PT S1 SS STXT)
(setvar "cmdecho" 0)
(command "undo" "be")
(setq stxt (getstring "\n输入查找的文字 :"))

(if (and (= stxt "")
      (setq s1 (entsel "\n选择要查找的文字 :"))
      (setq ent (entget(car s1)))
      (= (cdr(assoc 0 ent)) "TEXT"))
  (setq stxt (cdr(assoc 1 (entget(car s1)))))
)
(if (and  (setq ss (ssget (list '(0 . "TEXT") (cons 1 (strcat "*" stxt "*")))))
      (setq getpt(getpoint "\n指定线的起点："))
   )
  (progn
  (setq i 0)
  (repeat (sslength ss)
(setq en (ssname ss i))
(vla-getboundingbox(vlax-ename->vla-object en) 'minp 'maxp)
(setq minp (vlax-safearray->list minp)
      maxp (vlax-safearray->list maxp))
(setq pt (polar minp (angle minp maxp) (/ (distance minp maxp) 2)))
(entmake (list '(0 . "LINE") (cons 8 "FindText")(cons 10 getpt) (cons 11 pt)(cons 62 6) ))
(setq i (1+ i))
  )
  (princ)
))
(command "undo" "end")
(setvar "CMDECHO" 1)
(princ)
)

bai2000 · 发表于 2017-8-7 20:36:57

同求

yaoguen · 发表于 2017-8-9 13:04:43

永不言弃发表于 2017-8-8 09:38
我有一个这样的

需要这样的插件，大牛能分享一下吗？我的QQ：80872969，谢谢！

jun353835273 · 发表于 2017-8-9 17:19:33

[code](defun c:czwz1 ( / EN ENT GETPT I MAXP MINP PT S1 SS STXT)
(setvar "cmdecho" 0)
(command "undo" "be")
(setq stxt (getstring "\n输入查找的文字 :"))

(if (and (= stxt "")
      (setq s1 (entsel "\n选择要查找的文字 :"))
      (setq ent (entget(car s1)))
      (= (cdr(assoc 0 ent)) "TEXT"))
  (setq stxt (cdr(assoc 1 (entget(car s1)))))
)
(if (and  (setq ss (ssget (list '(0 . "TEXT") (cons 1 (strcat "*" stxt "*")))))
      (setq getpt(getpoint "\n指定线的起点："))

nishuihanjian · 发表于 2017-9-6 10:02:51

jun353835273 发表于 2017-8-9 17:21
(defun c:czwz1 ( / EN ENT GETPT I MAXP MINP PT S1 SS STXT)
(setvar "cmdecho" 0)
(command "undo" "b ...

表示CAD2010不能用，不能画线

669423907 · 发表于 2017-9-14 11:43:47

jun353835273 发表于 2017-8-9 17:21
(defun c:czwz1 ( / EN ENT GETPT I MAXP MINP PT S1 SS STXT)
(setvar "cmdecho" 0)
(command "undo" "b ...

程序很好用，请问如果要改为默认全选，要怎么改吖

alexmai · 发表于 2017-9-15 09:14:12

程序不能读属性块的文字，如何解决？

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

[提问] 快速找出所含文字并用圆形云线框出来

本帖子中包含更多资源

评分

点评

评分

本帖子中包含更多资源