设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 关于"屏幕选字"之<三领设计 SLdesign V3.0>的展 ...
返回列表 发新帖
查看: 1013|回复: 5

[资源] 关于"屏幕选字"之<三领设计 SLdesign V3.0>的展示

  [复制链接]
尘缘一生
发表于 2024-4-16 02:43:48 | 显示全部楼层 |阅读模式
本帖最后由 尘缘一生 于 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支持集成
  2. (defun c:tt ()
  3.   (while (setq e1
  4.            (clh-entsel
  5.              (slmsg
  6.                "\n -> 拖动决定替换字符串 [输入(左键)/取词(TAB)/删除(空格)/取消(右键)]"
  7.                "\n -> ╈笆∕﹚蠢传才﹃ [块(オ龄)/迭(TAB)/埃()/(龄)]"
  8.                "\n ->Drag to determine the replacement string [Enter (left click)/Take words (TAB)/Delete (space)/Cancel (right click)]"
  9.              ) "nil" '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT")) str1)
  10.          )
  11.     (setq e (car e1) p0 (cadr e1))
  12.     ;(setvar "snapang" (sl-r2d (e-ang e p0)))
  13.     (substrdynamic e p0) ;动态取字
  14.     ;(setvar "snapang" 0)
  15.     (setq e nil e1 nil p0 nil)
  16.   )
  17. )

  19. ;TEXT屏幕动态选字---(一级)-----
  20. ;e实体名 p0 e实体范围内点
  21. (defun substrdynamic (e p0 / ss2 sss s1 code p01 n newe color newcolor newstr newe2 ang nam e1 p1 p2 p3 p4 tp)
  22.   (setq color (vla-get-color (en2obj e)) newcolor 1)
  23.   (setq tp (dxf1 e 0) e1 (entlast) sss (ssadd))
  24.   (wzcf (ssadd e));炸碎
  25.   (if (and (setq ss2 (last_ent e1))
  26.         (setq newe (car (nentselp p0)))
  27.       )
  28.     (progn
  29.       (mapcar '(lambda (x) (vla-put-color (en2obj x) color)) (ss-enlst ss2))
  30.       (setq ang (angle-sharp (dxf1 newe 50)) p1 (dxf1 newe 10) p4 (polar p1 (+ ang pi2) (dxf1 newe 40)))
  31.       (if (= (vla-get-color (en2obj newe)) newcolor) (setq newcolor (atoi (slsjqs))))
  32.       (while (and (setq code (grread t 15 2)) (= (car code) 5)) ;拖动
  33.         (redraw)
  34.         (setq p01 (cadr code))
  35.         (setq sss (ssget "c" p0 p01 '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT"))))
  36.         (setq n 1)
  37.         (while (and (not sss) (< n 50))
  38.           (setq sss (ssget "c" p0 (mapcar '(lambda (x) (+ x (* n (getvar 'pickbox)))) p01) '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT"))))
  39.           (setq n (1+ n))
  40.         )
  41.         (setq p2 (polar p1 ang 400)
  42.           p2 (pertolinecz p01 p1 p2)
  43.           p3 (polar p4 ang 400)
  44.           p3 (pertolinecz p01 p4 p3)
  45.         )
  46.         (grdraw p1 p2 2 2)
  47.         (grdraw p2 p3 2 2)
  48.         (grdraw p3 p4 2 2)
  49.         (grdraw p4 p1 2 2)
  50.         (mapcar '(lambda (x) (vla-put-color (en2obj x) newcolor)) (ss-enlst sss))
  51.       )
  52.       (cond
  53.         ((= (car code) 3)  ;左键取词修改
  54.           (setq newstr (dclxz ""))
  55.         )
  56.         ((member code '((2 9))) ;;table 键
  57.           (setq newstr (sl-qc))
  58.         )
  59.       )
  60.       (if newstr
  61.         (progn
  62.           (setq s1 (entget (setq newe2 (ssname sss (1- (sslength sss))))))
  63.           (setq s1 (subst (cons 1 newstr) (assoc 1 s1) s1))
  64.           (entmod s1)
  65.           (entupd newe2)
  66.           (ssdel newe2 sss)
  67.         )
  68.       )
  69.       (setq n -1)
  70.       (while (setq nam (ssname sss (setq n (1+ n))))
  71.         (ssdel nam ss2)
  72.         (entdel nam)
  73.       )
  74.       (if (member tp '("TEXT" "TCH_TEXT" "SWR_TEXT"))
  75.         (wzhb ss2)
  76.         (sswzhb ss2)
  77.       )
  78.       (setq ss2 nil)
  79.     )
  80.   )
  81.   (redraw)
  82.   (princ)
  83. )


对于拖动，PICBOX选择问题，思考应该有其他办法为好，不知各位有好思路吗？

改动做法如下：
  2. ;TEXT屏幕动态选字---(一级)-----
  3. ;e实体名 p0 e实体范围内点
  4. (defun substrdynamic (e p0 / ss2 sss s1 code p01 n newe color newcolor newstr newe2 ang nam e1 p1 p2 p3 p4 tp h)
  5.   (setq color (vla-get-color (en2obj e)) newcolor 1)
  6.   (setq tp (dxf1 e 0) e1 (entlast) sss (ssadd))
  7.   (wzcf (ssadd e));炸碎
  8.   (if (and (setq ss2 (last_ent e1))
  9.         (setq newe (car (nentselp p0)))
  10.       )
  11.     (progn
  12.       (mapcar '(lambda (x) (vla-put-color (en2obj x) color)) (ss-enlst ss2))
  13.       (setq ang (angle-sharp (dxf1 newe 50)) h (dxf1 newe 40) p1 (dxf1 newe 10) p4 (polar p1 (+ ang pi2) h))
  14.       (if (= (vla-get-color (en2obj newe)) newcolor) (setq newcolor (atoi (slsjqs))))
  15.       (while (and (setq code (grread t 15 2)) (= (car code) 5)) ;拖动
  16.         (redraw)
  17.         (setq p01 (cadr code))
  18.         (setq sss (ssget "c" p0 p01 '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT"))))
  19.         (setq n 1 h (* 0.9 h))
  20.         (while (and (not sss) (< n 50))
  21.           (setq sss
  22.             (ssget "cp"
  23.               (list
  24.                 (polar p0 (+ ang pi2) h)
  25.                 (polar p0 (- ang pi2) h)
  26.                 (polar p01 (+ ang pi2) h)
  27.                 (polar p01 (- ang pi2) h)
  28.               )
  29.               '((0 . "TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,SWR_TEXT"))
  30.             )
  31.           )
  32.           (setq n (1+ n))
  33.         )
  34.         (setq p2 (polar p1 ang 400)
  35.           p2 (pertolinecz p01 p1 p2)
  36.           p3 (polar p4 ang 400)
  37.           p3 (pertolinecz p01 p4 p3)
  38.         )
  39.         (grdraw p1 p2 2 2)
  40.         (grdraw p2 p3 2 2)
  41.         (grdraw p3 p4 2 2)
  42.         (grdraw p4 p1 2 2)
  43.         (mapcar '(lambda (x) (vla-put-color (en2obj x) newcolor)) (ss-enlst sss))
  44.       )
  45.       (cond
  46.         ((= (car code) 3)  ;左键取词修改
  47.           (setq newstr (dclxz ""))
  48.         )
  49.         ((member code '((2 9))) ;;table 键
  50.           (setq newstr (sl-qc))
  51.         )
  52.       )
  53.       (if newstr
  54.         (progn
  55.           (setq s1 (entget (setq newe2 (ssname sss (1- (sslength sss))))))
  56.           (setq s1 (subst (cons 1 newstr) (assoc 1 s1) s1))
  57.           (entmod s1)
  58.           (entupd newe2)
  59.           (ssdel newe2 sss)
  60.         )
  61.       )
  62.       (setq n -1)
  63.       (while (setq nam (ssname sss (setq n (1+ n))))
  64.         (ssdel nam ss2)
  65.         (entdel nam)
  66.       )
  67.       (if (member tp '("TEXT" "TCH_TEXT" "SWR_TEXT"))
  68.         (wzhb ss2)
  69.         (sswzhb ss2)
  70.       )
  71.       (setq ss2 nil)
  72.     )
  73.   )
  74.   (redraw)
  75.   (princ)
  76. )



本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x
"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

尘缘一生
 楼主| 发表于 2024-4-16 03:52:15 | 显示全部楼层
本帖最后由 尘缘一生 于 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

回复 支持 1 反对 0

使用道具 举报

tranque
发表于 2024-4-16 10:19:07 | 显示全部楼层
尘缘前辈，一大清晨就写代码了
回复 支持 反对

使用道具 举报

尘缘一生
 楼主| 发表于 2024-4-16 20:15:51 | 显示全部楼层
tranque 发表于 2024-4-16 10:19
尘缘前辈，一大清晨就写代码了

晚上工作，下午睡觉，黑白颠倒。
回复 支持 反对

使用道具 举报

sachindkini
发表于 2024-7-8 18:56:33 | 显示全部楼层
beautiful
thanks for sharing

点评

尘缘一生
The English version CAD garbled code issue I found has been rewritten. You can download a new package to try it out.  发表于 2024-7-8 19:13
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-25 13:52 , Processed in 0.172368 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表