求将文字移动到圆心的LISP代码

清风明月名字 · 发表于 2013-11-8 19:38

请问，有没有将选中的文字和圆去计算它们的距离，将距离圆最小的文字的对齐点移动到圆心的插件
请高手帮我写一个，好后我会在帖子后面给你加分。无论多少套不同的，我都会给币。
就是将文字移入圆中，文字对齐点与圆心坐标相等。
文字与圆都是用户选择的，而不是只选择圆，由程序去在全图中找文字。

llsheng_73 · 发表于 2013-11-9 00:24

本帖最后由 llsheng_73 于 2014-7-23 17:55 编辑

(defun c:tt(/ s1 s2 sstoes a b);|如果有两个文字距一个圆距离一样远，会移动最后写入的那个文字|;
(defun SstoEs(ss / a en lst)
(if ss(progn(setq a -1)
(while(setq en(ssname ss(setq a(1+ a))))(setq lst(cons en lst)))))
lst)
(prompt "请选择圆和要移到圆中的文字")
(setq s1(SstoEs(ssget'((0 . "CIRCLE,TEXT"))))s2'())
(foreach a s1
(if (=(vla-get-objectname(vlax-ename->vla-object a))"AcDbText")
(setq s1(vl-remove a s1)s2(cons a s2))))
(foreach a s1
(if s2(entmod(setq p(cdr(assoc 10(entget a)))
b(car(vl-sort(mapcar'(lambda(x)(setq b(entget x)q(if(equal'(11 0 0 0)(assoc 11 b))(assoc 10 b)(assoc 11 b)))
(list(distance(cdr q)p)q x))s2)'(lambda(x y)(<(car x)(car y)))))
s2(vl-remove(caddr b)s2)
b(subst(cons(caadr b)p)(cadr b)(entget(caddr b)))))))
(princ)
)

可能有的情况没考虑到，因为你也没明确提出,不过做出来的跟你的描述还是有点小差别。程序是以圆为基准，去找距离它最近的文字把它拉进来，而不是以文字出发，找到距离它最近的圆跑到里边去，这两者是不一样的, 前者它只能拉一个文字进去，后者可能几个文字跑到一个圆里边还是挂个附件吧，好象复制的代码总会显得比较凌乱已更正无文字时出错的问题及有的文字对正方式无法移动文字的问题，感谢大家测试反馈 IE有问题，附件无法更新，只能麻烦热心的朋友复制代码了

llsheng_73 · 发表于 2013-11-8 23:47

文字与圆个数能保证相等么？
一个圆内只能移一个文字进去吧？

yoyoho · 发表于 2013-11-9 20:17

感谢 llsheng_73 分享程序!

liujing95 · 发表于 2013-11-12 17:05

数量多时，有些文字移到别的圆上了，很期待改善

liujing95 · 发表于 2013-11-12 17:19

假于选择的里面有圆旁边没有文字的就会出错

Kye · 发表于 2014-7-21 21:10

本帖最后由 Kye 于 2014-7-24 20:56 编辑

llsheng_73 发表于 2013-11-9 00:24
可能有的情况没考虑到，因为你也没明确提出,不过做出来的跟你的描述还是有点小差别。程序是以圆为基准，去 ...

2006 2007 在XP 2010 在win7 没有通过，文字是text命令写的，请哪位大侠帮忙看看；今天上传遇到点问题，明天换台电脑将测试的dwg放上

;;;;;留下自己学习足迹，谢谢大侠llsheng_73，附件tt.dwg能通过了,文字中心还不是在圆心对组码73表示很糊涂，希望llsheng_73大侠不要介意我的涂鸦修改

(defun c:tt (/ s1 s2 sstoes a b c d);|如果有两个文字距一个圆距离一样远，会移动最后写入的那个文字|;

  (defun SstoEs (ss / a en lst);;;;选择集转表
(if ss
   (progn (setq a -1)
   (while (setq en (ssname ss (setq a (1+ a))))
      (setq lst (cons en lst))
   )
   )
)
lst
  )
  (prompt "请选择圆和要移到圆中的文字")
  (setq s1 (SstoEs (ssget  "_:L" '((0 . "CIRCLE,TEXT"))))
s2 '()
  )
  (foreach a s1
(if (/= (cdr (assoc 0 (entget a))) "CIRCLE");;
   (setq s1 (vl-remove a s1);;剩下的S1为circle表
   s2 (append (list a) s2);;新建S2 TEXT表
   )
)
  );;;拆分;谢谢大侠llsheng_73 ,学习了foreach 函数

  (foreach a s1
(setq p (cdr (assoc 10 (entget a)))
d '(1e10)
)
(foreach b s2
   (setq q (cdr (assoc 10 (entget b)));;将组码11改为10
   c (distance p q)
   d (if (< c (car d))
  (list c b)
  d
   )
   )
)
(if (= (length d) 2)
   (entmod (setq c  (nth 1 d)
   s2 (vl-remove c s2)
   c  (subst (cons 10 p) (assoc 10 (entget c)) (entget c));;将组码11改为10
   )
   )
)
  )
  (princ)
)

Kye · 发表于 2014-7-24 08:54

对llsheng_73 大侠的更新深表敬意

测试OK,谢谢llsheng_73 大侠

迹扬 · 发表于 2014-11-29 22:50

llsheng_73 发表于 2013-11-9 00:24
本帖最后由 llsheng_73 于 2014-7-23 17:55 编辑可能有的情况没考虑到，因为你也没明确提出,不过做出来的 ...

如果要是文字和引线的批量对齐，要怎么修改呢？
引线是LEADER，不是直线

llsheng_73 · 发表于 2014-11-30 14:12

迹扬发表于 2014-11-29 22:50
如果要是文字和引线的批量对齐，要怎么修改呢？
引线是LEADER，不是直线

理论上说是可以的，但没研究过引线，因为没涉及到。。。。道理和方法是一样的，不同的是不同图元需要关心的组码不同。。。找准它的关键组码应该可以

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

[已解答] 求将文字移动到圆心的LISP代码

本帖子中包含更多资源

相关帖子

本帖子中包含更多资源

点评

评分

本帖子中包含更多资源