关于"屏幕选字"之<三领设计 SLdesign V3.0>的展示
本帖最后由 尘缘一生 于 2024-4-16 04:09 编辑原帖子地址：
http://bbs.mjtd.com/forum.php?mo ... 1%C4%BB%D1%A1%D7%D6
这个功能是比较有用的，
三领做了点集成：
1：对任意角度的文字支持
2：对任意炸碎的文字支持
3：集成TAB键取词库
4：对选中的文字画出矩形矢量框，变色系统保留
5：对MTEXT支持集成
(defun c:tt ()
(while (setq e1
(clh-entsel
(slmsg
"\n -> 拖动决定替换字符串 [输入(左键)/取词(TAB)/删除(空格)/取消(右键)]"
"\n -> ╈笆∕﹚蠢传才﹃ [块(オ龄)/迭(TAB)/埃()/(龄)]"
"\n ->Drag to determine the replacement string "
) "nil" '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT")) str1)
)
(setq e (car e1) p0 (cadr e1))
;(setvar "snapang" (sl-r2d (e-ang e p0)))
(substrdynamic e p0) ;动态取字
;(setvar "snapang" 0)
(setq e nil e1 nil p0 nil)
)
)
;TEXT屏幕动态选字---(一级)-----
;e实体名 p0 e实体范围内点
(defun substrdynamic (e p0 / ss2 sss s1 code p01 n newe color newcolor newstr newe2 ang nam e1 p1 p2 p3 p4 tp)
(setq color (vla-get-color (en2obj e)) newcolor 1)
(setq tp (dxf1 e 0) e1 (entlast) sss (ssadd))
(wzcf (ssadd e));炸碎
(if (and (setq ss2 (last_ent e1))
(setq newe (car (nentselp p0)))
)
(progn
(mapcar '(lambda (x) (vla-put-color (en2obj x) color)) (ss-enlst ss2))
(setq ang (angle-sharp (dxf1 newe 50)) p1 (dxf1 newe 10) p4 (polar p1 (+ ang pi2) (dxf1 newe 40)))
(if (= (vla-get-color (en2obj newe)) newcolor) (setq newcolor (atoi (slsjqs))))
(while (and (setq code (grread t 15 2)) (= (car code) 5)) ;拖动
(redraw)
(setq p01 (cadr code))
(setq sss (ssget "c" p0 p01 '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT"))))
(setq n 1)
(while (and (not sss) (< n 50))
(setq sss (ssget "c" p0 (mapcar '(lambda (x) (+ x (* n (getvar 'pickbox)))) p01) '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT"))))
(setq n (1+ n))
)
(setq p2 (polar p1 ang 400)
p2 (pertolinecz p01 p1 p2)
p3 (polar p4 ang 400)
p3 (pertolinecz p01 p4 p3)
)
(grdraw p1 p2 2 2)
(grdraw p2 p3 2 2)
(grdraw p3 p4 2 2)
(grdraw p4 p1 2 2)
(mapcar '(lambda (x) (vla-put-color (en2obj x) newcolor)) (ss-enlst sss))
)
(cond
((= (car code) 3);左键取词修改
(setq newstr (dclxz ""))
)
((member code '((2 9))) ;;table 键
(setq newstr (sl-qc))
)
)
(if newstr
(progn
(setq s1 (entget (setq newe2 (ssname sss (1- (sslength sss))))))
(setq s1 (subst (cons 1 newstr) (assoc 1 s1) s1))
(entmod s1)
(entupd newe2)
(ssdel newe2 sss)
)
)
(setq n -1)
(while (setq nam (ssname sss (setq n (1+ n))))
(ssdel nam ss2)
(entdel nam)
)
(if (member tp '("TEXT" "TCH_TEXT" "SWR_TEXT"))
(wzhb ss2)
(sswzhb ss2)
)
(setq ss2 nil)
)
)
(redraw)
(princ)
)
对于拖动，PICBOX选择问题，思考应该有其他办法为好，不知各位有好思路吗？
改动做法如下：
;TEXT屏幕动态选字---(一级)-----
;e实体名 p0 e实体范围内点
(defun substrdynamic (e p0 / ss2 sss s1 code p01 n newe color newcolor newstr newe2 ang nam e1 p1 p2 p3 p4 tp h)
(setq color (vla-get-color (en2obj e)) newcolor 1)
(setq tp (dxf1 e 0) e1 (entlast) sss (ssadd))
(wzcf (ssadd e));炸碎
(if (and (setq ss2 (last_ent e1))
(setq newe (car (nentselp p0)))
)
(progn
(mapcar '(lambda (x) (vla-put-color (en2obj x) color)) (ss-enlst ss2))
(setq ang (angle-sharp (dxf1 newe 50)) h (dxf1 newe 40) p1 (dxf1 newe 10) p4 (polar p1 (+ ang pi2) h))
(if (= (vla-get-color (en2obj newe)) newcolor) (setq newcolor (atoi (slsjqs))))
(while (and (setq code (grread t 15 2)) (= (car code) 5)) ;拖动
(redraw)
(setq p01 (cadr code))
(setq sss (ssget "c" p0 p01 '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT"))))
(setq n 1 h (* 0.9 h))
(while (and (not sss) (< n 50))
(setq sss
(ssget "cp"
(list
(polar p0 (+ ang pi2) h)
(polar p0 (- ang pi2) h)
(polar p01 (+ ang pi2) h)
(polar p01 (- ang pi2) h)
)
'((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT"))
)
)
(setq n (1+ n))
)
(setq p2 (polar p1 ang 400)
p2 (pertolinecz p01 p1 p2)
p3 (polar p4 ang 400)
p3 (pertolinecz p01 p4 p3)
)
(grdraw p1 p2 2 2)
(grdraw p2 p3 2 2)
(grdraw p3 p4 2 2)
(grdraw p4 p1 2 2)
(mapcar '(lambda (x) (vla-put-color (en2obj x) newcolor)) (ss-enlst sss))
)
(cond
((= (car code) 3);左键取词修改
(setq newstr (dclxz ""))
)
((member code '((2 9))) ;;table 键
(setq newstr (sl-qc))
)
)
(if newstr
(progn
(setq s1 (entget (setq newe2 (ssname sss (1- (sslength sss))))))
(setq s1 (subst (cons 1 newstr) (assoc 1 s1) s1))
(entmod s1)
(entupd newe2)
(ssdel newe2 sss)
)
)
(setq n -1)
(while (setq nam (ssname sss (setq n (1+ n))))
(ssdel nam ss2)
(entdel nam)
)
(if (member tp '("TEXT" "TCH_TEXT" "SWR_TEXT"))
(wzhb ss2)
(sswzhb ss2)
)
(setq ss2 nil)
)
)
(redraw)
(princ)
)
本帖最后由 尘缘一生 于 2024-4-16 04:10 编辑
再次完善一下子:更加丝滑顺畅
[*];屏幕动态选字---(一级)-----
[*];e实体名 p0 e实体范围内点
[*](defun substrdynamic (e p0 / ss2 sss s1 code p01 n newe color newcolor newstr newe2 ang nam e1 p1 p2 p3 p4 tp)
[*](setq color (vla-get-color (en2obj e)) newcolor 1)
[*](setq tp (dxf1 e 0) e1 (entlast) sss (ssadd))
[*](wzcf (ssadd e));炸碎
[*](if (and (setq ss2 (last_ent e1))
[*] (setq newe (car (nentselp p0)))
[*] )
[*] (progn
[*] (mapcar '(lambda (x) (vla-put-color (en2obj x) color)) (ss-enlst ss2))
[*] (setq ang (dxf1 newe 50) p1 (dxf1 newe 10) p4 (polar p1 (+ ang pi2) (dxf1 newe 40)))
[*] (entmod (emod (emod newe 72 0) 73 0)) ;;左下定位
[*] (if (= (vla-get-color (en2obj newe)) newcolor) (setq newcolor (atoi (slsjqs))))
[*] (while (and (setq code (grread t 15 2)) (= (car code) 5)) ;拖动
[*] (redraw)
[*] (setq p01 (cadr code))
[*] (setq sss (ssget "c" p0 p01 '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT"))))
[*] (setq p2 (polar p1 ang 400)
[*] p2 (pertolinecz p01 p1 p2)
[*] p3 (polar p4 ang 400)
[*] p3 (pertolinecz p01 p4 p3)
[*] )
[*] (grdraw p1 p2 2 2)
[*] (grdraw p2 p3 2 2)
[*] (grdraw p3 p4 2 2)
[*] (grdraw p4 p1 2 2)
[*] (setq n 1)
[*] (while (and (not sss) (< n 50))
[*] (setq sss (ssget "cp" (list p1 p2 p3 p4) '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT"))))
[*] (setq n (1+ n))
[*] )
[*] (mapcar '(lambda (x) (vla-put-color (en2obj x) newcolor)) (ss-enlst sss))
[*] )
[*] (cond
[*] ((= (car code) 3);左键取词修改
[*] (setq newstr (dclxz ""))
[*] )
[*] ((member code '((2 9))) ;;table 键
[*] (setq newstr (sl-qc))
[*] )
[*] )
[*] (if newstr
[*] (progn
[*] (setq s1 (entget (setq newe2 (ssname sss (1- (sslength sss))))))
[*] (setq s1 (subst (cons 1 newstr) (assoc 1 s1) s1))
[*] (entmod s1)
[*] (entupd newe2)
[*] (ssdel newe2 sss)
[*] )
[*] )
[*] (setq n -1)
[*] (while (setq nam (ssname sss (setq n (1+ n))))
[*] (ssdel nam ss2)
[*] (entdel nam)
[*] )
[*] (if (member tp '("TEXT" "TCH_TEXT" "SWR_TEXT"))
[*] (wzhb ss2)
[*] (sswzhb ss2)
[*] )
[*] (setq ss2 nil)
[*] )
[*])
[*](redraw)
[*](princ)
[*])
SLdesign APP
链接：https://pan.baidu.com/s/1uw74-TQiSNcmdVLxoER-kg 提取码：y7ek
尘缘前辈，一大清晨就写代码了 tranque 发表于 2024-4-16 10:19
尘缘前辈，一大清晨就写代码了
晚上工作，下午睡觉，黑白颠倒。 beautiful
thanks for sharing
页:
[1]