求助代码修改
下面是论坛上的代码，文字查找并标记，如何改一下实现：新建图层aa，并把标记放图层aa上
;;http://bbs.mjtd.com/forum.php?mod=viewthread&tid=175593&extra=&highlight=%B2%E9%D5%D2&page=2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;查找文字2017.09.04增加通配符
(defun czt (sst hand1 / filter sst ss enttxt po ptmid i SearchTXT)
(if sst
(progn ;_1
(setq filter (list '(0 . "*TEXT") (cons 1 sst)))
(if (= hand1 "1")
(setq ss (ssget "x" (list '(0 . "*TEXT") (cons 1 sst))))
(setq ss (ssget (list '(0 . "*TEXT") (cons 1 sst))))
)
(if (and (= radio1 "1") ss);
(progn
;;; (setq basepoint (getpoint "\n指定线段发射基点:"))
(setq entPtLst '())
(setq i 0)
(repeat (sslength ss)
(setq enttxt (ssname ss i))
(setq po (cdr (assoc 10 (entget enttxt))))
(setq ptmid (getmidpo (entbox enttxt)))
(setq entPtLst (cons ptmid entPtLst))
;;; (if basepoint
;;; (entmakex (list '(0 . "line") '(100 . "AcDbEntity") '
;;; (100 . "ACDbCircle") (cons 8 "-文字线")(cons 10 ptmid)
;;; (cons 11 basepoint)(cons 62 1) '(210 0. 0. 1.))
;;;)
;;; )
(setq i (+ 1 i))
)
;;; (princ (strcat "成功处理：" (rtos i) "个对象"))
(setq SearchTXT (strcat "成功查找：" findtxt" 共"(rtos i 5) "个对象"))
(dynamicMTxt SearchTXT 8 entPtLst)
)
;(princ "\n没有找到对象!")
)
(if (and (= radio2 "1") ss)
(sssetfirst nil ss)
)
) ;_progn 1
(alert "\n您没有选择文字哦!!!")
)
;(endcmd)
(princ)
)
(defun textstring_find ( / $value Return enttxt findtxt idcl_idtxt po ptmid @dclfiledame)
(defun write-dialog (dialog_string_1st / @dclfiledame @dclfiled)
(setq @dclfiledame (vl-filename-mktemp nil nil ".dcl"))
(setq @dclfiled (open @dclfiledame "w"))
(foreach x dialog_string_1st
(write-line x @dclfiled)
)
(close @dclfiled)
@dclfiledame
)
(setq findtext:dialog-lst
(list
"findtext:dialog{"
"//:text{label=\"支持通配符*查找\";is_enabled = false;}"
"label=\"文字查找\";"
":column{//label=\"文字\";boxed_row"
":row{"
"label = \"是否做标记\";"
":row{"
":radio_button{label=\"是\";key=\"radio1\";}"
":radio_button{label=\"否\";key=\"radio2\";}"
"}"
":toggle{label=\"加前通配符\";key=\"tog1\";}"
":toggle{label=\"加后通配符\";key=\"tog2\";}"
":toggle{label=\"全图\";key=\"hand1\";}"
"}"
":row{"
"label = \"文本输入\";"
":column{"
":edit_box{label=\"输入文字:\";"
"initial_focus=\"text2\";"
"key=\"text2\";"
"edit_width=30;"
"fixed_width=true;"
"}"
"} "
"} //column"
"} //boxed_row"
"//:text{label=\"Design by:半途中 QQ:455383153\";is_enabled = false;}"
"ok_cancel;"
"}"
)
)
(setq @dclfiledame(write-dialog findtext:dialog-lst))
(if (and (= radio1 nil) (= radio2 nil))
(setqradio1 "1"
radio2 "0"
)
)
(if (not tog1)
(setq tog1 "0")
)
(if (not tog2)
(setq tog2 "0")
)
(if (not hand1)
(setq hand1 "0")
)
(if (not text2findtxt_name)
(setq text2findtxt_name "请输入查找的文字")
)
(prompt "\n请选择：")
(setq idcl_idtxt (load_dialog @dclfiledame))
(new_dialog "findtext" idcl_idtxt)
(set_tile "text2" text2findtxt_name)
(set_tile "radio1" radio1)
(set_tile "radio2" radio2)
(set_tile "tog1" tog1)
(set_tile "tog2" tog2)
(set_tile "hand1" hand1)
(mode_tile "text2" 2)
(action_tile "radio1" "(setq radio1 (vl-princ-to-string 1))(setq radio2(vl-princ-to-string 0) )")
(action_tile "radio2" "(setq radio2 (vl-princ-to-string 1))(setq radio1 (vl-princ-to-string 0))")
(action_tile "tog1" "(setq tog1 $value)")
(action_tile "tog2" "(setq tog2 $value)")
(action_tile "hand1" "(setq hand1 $value)")
(action_tile "text2" "(setq text2findtxt_name (get_tile \"text2\"))")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(setq Return (start_dialog))
(unload_dialog idcl_idtxt)
(vl-file-delete @dclfiledame)
(IF (= Return 1)
(progn
(if (and (= tog1 "1") (= tog2 "1"))
(setq findtxt (strcat "*" text2findtxt_name "*"))
)
(if (and (= tog1 "1") (= tog2 "0"))
(setq findtxt (strcat "*" text2findtxt_name))
)
(if (and (= tog1 "0") (= tog2 "1"))
(setq findtxt (strcat text2findtxt_name "*"))
)
(if (and (= tog1 "0") (= tog2 "0"))
(setq findtxt text2findtxt_name)
)
(czt findtxt hand1)
)
)
(princ)
);;;defun
;;单个物体的最小（正交）包围框
(defun entbox (ent / ll ur)
(vl-load-com)
(vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
(mapcar 'vlax-safearray->list (list ll ur))
)
;;求两点中点
(defun getmidpo(pts / P1 P2 X Y)
(setqp1 (car pts)
p2 (cadr pts)
)
(if (= (length p1) (length p2))
nil
(setq p1 (list (car p1) (cadr p1))
p2 (list (car p2) (cadr p2))
)
)
(mapcar '(lambda (X Y) (* (+ X Y) 0.5)) P1 P2)
)
(defun dynamicMTxt (MtextStr high pntlst / entlist pt CNTNNEW MOUSE MseButton ENT MsePt);_by wizman
(setq entlist '())
(foreach x pntlst
(setq pt x)
(setq entlist (cons (MkRedLine x pt) entlist))
)
(entmake (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText") '(7 . "Standard")(CONS 40 high) (cons 62 3)(cons 1 MtextStr) (cons 10 (cadr (grread t 13 1)))))
(setq CnTnNew t)
(while (and (or (= (car (setq mouse (grread t 13 1))) 5)
(= (car mouse) 12)
(= (car mouse) 2)
)
CnTnNew
)
;_ 所谓grread函数就是不断重新画图，直到给点为止。
(setq MseButton (car mouse))
(if(= MseButton 2) ;_点右键
(setq CnTnNew nil)
)
(if(= MseButton 3) ;_点左键3为正常的鼠标左键，
(setq CnTnNew nil)
)
(if(= MseButton 5) ;_5为移动点
(progn
(setq ent (entlast))
(if ent
(entdel ent)
)
(setq MsePt (cadr mouse))
(entmake (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText") '(7 . "Standard")(CONS 40 high)(cons 62 3) (cons 1 MtextStr) (cons 10 MsePt)))
(foreach x entlist
(upd x 11 MsePt)
(not (redraw x 3))
)
) ;_progn
);_if
) ;_while
(princ)
)
(defun MKRedLine(pt1 pt2)
(entmakex (list '(0 . "LINE") (cons 62 1)(cons 10 pt1) (cons 11 pt2)))
)
;;更新组码值
(defun upd (e i v / a)
(setq e (entget e))
(if (setq a (assoc i e))
(entmod (subst (cons i v) a e))
)
)
(princ)
(princ"\n字符查找,命令TTF")
(defun c:ttf ()(textstring_find))
替换后面的TTF，按理来说你都是金牌会员了不应该不会啊
(defun c:ttf ()
(SETVAR "CMDECHO" 0)
(command "-layer" "m" "aa" "c" 1 """L" "continuous" "" "")
(textstring_find)
)
页:
[1]