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

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 批量文字矩形框改为圆，代码问题请教
12下一页
返回列表 发新帖
查看: 1431|回复: 14

[讨论] 批量文字矩形框改为圆，代码问题请教

[复制链接]
meja
发表于 2023-6-18 09:21:36 | 显示全部楼层 |阅读模式
本帖最后由 meja 于 2023-6-18 18:04 编辑
  2. (defun C:TextBox
  3.   (/ CurSet CurEnt EntCnt PntLst RecEnt OffDst OffPnt OldCmd OldUci OldUcf)
  4.   (setq CurSet
  5.     (cond
  6.       ((ssget "_I" '((0 . "TEXT"))))
  7.       (T (prompt "\nTo put boxes around Text,") (ssget '((0 . "TEXT"))))
  8.     ); cond
  9.   ); setq
  10.   (if CurSet
  11.     (progn
  12.       (setq
  13.         OldCmd (getvar "CMDECHO")
  14.         OldUci (getvar "UCSICON")
  15.         OldUcf (getvar "UCSFOLLOW")
  16.         EntCnt 0
  17.       ); setq
  18.       (setvar "CMDECHO" 0)
  19.       (if (= (logand (getvar "UNDOCTL") 4) 4)
  20.         (command "_.UNDO" "_GROUP")
  21.       )
  22.       (setvar "UCSICON" 0)
  23.       (setvar "UCSFOLLOW" 0)
  24.       (repeat (sslength CurSet)
  25.         (setq
  26.           CurEnt (ssname CurSet EntCnt)
  27.           CurEntD (entget CurEnt)
  28.           EntCnt (1+ EntCnt)
  29.         )
  30.         (command "_.UCS" "_OBJ" CurEnt)
  31.         (setq
  32.           PntLst (textbox CurEntD)
  33.           OffPnt (polar (cadr PntLst) 0 1)
  34.           OffDst (* (cdr (assoc 40 CurEntD)) 0.35) ;Distance Text -> Rectangle <--- or 0.5
  35.         ); setq
  36.         (command "_.RECTANGLE" (car PntLst) (cadr PntLst))
  37.         (setq RecEnt (entlast))
  38.         (command
  39.           "_.OFFSET" OffDst RecEnt OffPnt ""
  40.           "_.ERASE" RecEnt ""
  41.           "_.UCS" "_PRE"
  42.         ); command
  43.       ); repeat
  44.       (setvar "UCSICON" OldUci)
  45.       (setvar "UCSFOLLOW" OldUcf)
  46.       (if (= (logand (getvar "UNDOCTL") 4) 4)
  47.         (command "_.UNDO" "_END")
  48.       ); if
  49.       (setvar "CMDECHO" OldCmd)
  50.     ); progn
  51.   ); if
  52.   (princ)
  53. ); defun
官方大神 KENT COOPER 写的。（批量）完美运行，想知道这一句如何改成取中点

  2. (command "_.RECTANGLE" (car PntLst) (cadr PntLst))


回复

使用道具 举报

xyp1964
发表于 2023-6-20 00:02:26 | 显示全部楼层
meja 发表于 2023-6-18 13:16
院长，你这代码十年前就编好了吧，我是来请教改代码的

  1. (defun c:tt ()
  2.   (setq i 0)
  3.   (if (setq ss (ssget '((0 . "text"))))
  4.     (repeat (sslength ss)
  5.       (setq s1        (ssname ss i)
  6.             i        (1+ i)
  7.             ptn        (textbox (entget s1))
  8.             p10        (cdr (assoc 10 (entget s1)))
  9.             p1        (car ptn)
  10.             p2        (cadr ptn)
  11.             p1        (mapcar '(lambda (x y) (+ x y)) p1 p10)
  12.             p2        (mapcar '(lambda (x y) (+ x y)) p2 p10)
  13.             pc        (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2)
  14.             rr        (* (distance p1 p2) 0.5)
  15.       )
  16.       (command "circle" "non" pc rr)
  17.     )
  18.   )
  19.   (princ)
  20. )
回复 支持 反对

使用道具 举报

xyp1964
发表于 2023-6-21 12:31:19 | 显示全部楼层
meja 发表于 2023-6-20 08:33
对你的佩服犹如滔滔江水有本事追加一个对大部分图元（线 弧 字 块）加圆的

  1. (defun c:tt ()
  2.   (setq i 0)
  3.   (if (setq ss (ssget))
  4.     (repeat (sslength ss)
  5.       (setq s1        (ssname ss i)
  6.             i        (1+ i)
  7.             ptn (xyp-9ptLIst s1)
  8.             pc        (nth 4 ptn)
  9.               rr        (* (distance (car ptn) (last ptn)) 0.5)
  10.       )
  11.       (command "circle" "non" pc rr)
  12.     )
  13.   )
  14.   (princ)
  15. )
回复 支持 反对

使用道具 举报

meja
 楼主| 发表于 2023-6-18 20:46:39 | 显示全部楼层
  2.         (setq
  3.           PntLst (textbox CurEntD)
  4.           OffPnt (polar (cadr PntLst) 0 1)
  5.           OffDst (* (cdr (assoc 40 CurEntD)) 0.35) ;Distance Text -> Rectangle <--- or 0.5
  6.           po (MAPCAR '(lambda (X Y ) (* (+ X Y) 0.5)) (car PntLst) (cadr PntLst) )
  7.         ); setq
  8.         (command "_.CIRCLE" po 2 )   


正确的写法，搞出来了
回复 支持 反对

使用道具 举报

xyp1964
发表于 2023-6-18 11:39:44 | 显示全部楼层



  1. (defun c:tt ()
  2.   "批量文字加圆圈"
  3.   (setq i -1)
  4.   (if (setq ss (ssget '((0 . "TEXT"))))
  5.     (while (setq s1 (ssname ss (setq i (1+ i))))
  6.       (setq p5 (xyp-9pt s1 5))
  7.       (xyp-CircleCr p5 (distance (xyp-9pt s1 7) p5))
  8.     )
  9.   )
  10.   (princ)
  11. )


本帖子中包含更多资源

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

x
回复 支持 反对

使用道具 举报

meja
 楼主| 发表于 2023-6-18 13:16:42 | 显示全部楼层
xyp1964 发表于 2023-6-18 11:39

院长，你这代码十年前就编好了吧，我是来请教改代码的
回复 支持 反对

使用道具 举报

start4444
发表于 2023-6-18 16:11:40 | 显示全部楼层
(car PntLst) (cadr PntLst) 这就是矩形的对角点，找中点不是很简单吗
回复 支持 反对

使用道具 举报

meja
 楼主| 发表于 2023-6-18 18:02:39 来自手机 | 显示全部楼层
start4444 发表于 2023-6-18 16:11
(car PntLst) (cadr PntLst) 这就是矩形的对角点，找中点不是很简单吗

这种列表型我不太会改了。我只会改pt1和PT2的那种。可以指教怎么写吗？

点评

start4444
你就当他是pt1 pt2 就好了  发表于 2023-6-18 20:02
回复 支持 反对

使用道具 举报

meja
 楼主| 发表于 2023-6-18 20:36:44 | 显示全部楼层
start4444 发表于 2023-6-18 16:11
(car PntLst) (cadr PntLst) 这就是矩形的对角点，找中点不是很简单吗
  2. (command "_.CIRCLE" (* 0.5 (+ (car (car PntLst)) (car (cadr PntLst))) ) (* 0.5 (+ (cadr (car PntLst)) (cadr (cadr PntLst)))) (- (cadr (cadr PntLst)) (cadr (car PntLst)) ) )
改了，还是有问题
回复 支持 反对

使用道具 举报

依然小小鸟
发表于 2023-6-18 21:00:02 | 显示全部楼层
meja 发表于 2023-6-18 20:46
正确的写法，搞出来了

有最终组合再一起的完整代码吗
回复 支持 反对

使用道具 举报

meja
 楼主| 发表于 2023-6-18 21:32:13 | 显示全部楼层
依然小小鸟 发表于 2023-6-18 21:00
有最终组合再一起的完整代码吗

你覆盖一楼代码30-35行即可，代码用来学习的，经常犯错误才能改进
回复 支持 反对

使用道具 举报

MZ_li
发表于 2023-6-19 09:54:30 | 显示全部楼层
meja 发表于 2023-6-18 21:32
你覆盖一楼代码30-35行即可，代码用来学习的，经常犯错误才能改进

你这段的加圆不能圈在文字外框
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-11-16 22:49 , Processed in 0.189080 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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