求一个能自动调整文字下方PL线长度的程序

fire9527 · 发表于 2013-5-19 14:26:43

有时候变了字体或者文字内容，手动调整文字下方的引线长度好麻烦，因此想要这样一个程序
说明见插图
小弟财力有限，希望大侠不会计较，

llsheng_73 · 发表于 2013-5-19 14:26:44

本帖最后由 llsheng_73 于 2014-4-16 00:26 编辑

郁闷，给你弄了小半天，最后要回复的时候找不到这个帖子了，东找西找眼睛都看花了才找到地方

(Defun STB(TAB / snl sll)
(SetQ snl '()sll (TblNext TAB T))
(While (SetQ snl (Cons (Cdr (Assoc 2 sll)) snl)sll (TblNext TAB nil)))
(vl-sort snl '<))
(defun SStoES(s / m n e)
(if s(progn
(setq n(sslength s)m 0)
(while(< m n)
(setq e(if e(append e(list(ssname s m)))(list(ssname s m)))m(1+ m))))
)e)
(defun c:tt(/ la lys p p1 p2 pt s1 s2 e q1 q2 y);;引线只支持LWPOLYLINE,对于POLYLINE没有进行处理
(setq la nil p1 nil p2 nil
lys(STB"LAYER"))
(while(not(member la lys))(setq la(getstring(strcat"\n图层名"(vl-princ-to-string lys)":"))))
(while(null p1)(setq p1(getpoint"框选第一点")))
(setq p2(getcorner p1"框选第二点"))
(if p2(progn
(setq pt(list p1(list(car p1)(cadr p2)0)p2(list(cadr p1)(car p2)0))
s1(SSTOES(ssget "CP" pt(list(cons 0 "TEXT,MTEXT")(cons 8 la))))
s2(SSTOES(ssget "CP" pt(list(cons 0 "LWPOLYLINE")(cons 8 la)))))
(foreach e1 s1
(vla-getboundingbox(vlax-ename->vla-object e1)'p1 'p2)
(setq p1(vlax-safearray->list p1)
p2(vlax-safearray->list p2)pt nil
p(list(/(+(car p1)(car p2))2)(/(+(cadr p1)(cadr p2))2)))
(foreach e2 s2
(setq obj(vlax-ename->vla-object e2)
d1(distance(vlax-curve-getClosestPointTo obj p)p)
d2(distance(vlax-curve-getClosestPointTo obj p t)p)
pt(append pt(list(list d1 d2 e2)))))
(setq e1(nth 2(car(vl-sort pt(function(lambda(e1 e2)(<(car e1)(car e2)))))))
e2(nth 2(car(vl-sort pt(function(lambda(e1 e2)(<(cadr e1)(cadr e2))))))))
(setq e nil)
(if(/= e1 e2)(progn(command"zoom""C" p(/(getvar"VIEWSIZE")2))
(while(null e)(setq e(entsel"\n无法确定与该文字对应的注记线,需要你来确定")))
(setq e(car e))
(command"zoom""p"))
(setq e e1))
(setq e1(vlax-ename->vla-object e)
q1(vlax-curve-getstartPoint e1)
q2(vlax-curve-getendPoint e1)
e(entget e))
(if(>(-(cadr p1)(cadr q1))(-(cadr p1)(cadr q2)))
(setq p q1 y(cadr q2))
(setq p q2 y(cadr q1)))
(setq pt(list(list (car p1)y)(list(car p2)y)p))
(foreach e1 e
(if(=(car e1)10) (setq p(car pt)e(subst(list 10(car p)(cadr p))e1 e)pt(vl-remove p pt))))
(entmod e)
)))
)

(Defun STB(TAB / snl sll) 
  (SetQ snl '()sll (TblNext TAB T)) 
  (While (SetQ snl (Cons (Cdr (Assoc 2 sll)) snl)sll (TblNext TAB nil))) 
  (vl-sort snl '<)) 
 
(defun SStoES(s / m n e) 
  (if s(progn 
   (setq n(sslength s)m 0) 
   (while(< m n) 
     (setq e(if e(append e(list(ssname s m)))(list(ssname s m)))m(1+ m)))) 
    )e) 
 
(defun c:tt(/ la lys p p1 p2 pt s1 s2 e q1 q2 y);;引线只支持LWPOLYLINE,对于POLYLINE没有进行处理 
  (setq la nil p1 nil p2 nil 
  lys(STB"LAYER")) 
  (while(not(member la lys))(setq la(getstring(strcat"\n图层名"(vl-princ-to-string lys)":")))) 
  (while(null p1)(setq p1(getpoint"框选第一点"))) 
  (setq p2(getcorner p1"框选第二点")) 
  (if p2(progn 
    (setq pt(list p1(list(car p1)(cadr p2)0)p2(list(cadr p1)(car p2)0)) 
    s1(SSTOES(ssget "CP" pt(list(cons 0 "TEXT,MTEXT")(cons 8 la)))) 
    s2(SSTOES(ssget "CP" pt(list(cons 0 "LWPOLYLINE")(cons 8 la))))) 
    (foreach e1 s1 
      (vla-getboundingbox(vlax-ename->vla-object e1)'p1 'p2) 
      (setq p1(vlax-safearray->list p1) 
      p2(vlax-safearray->list p2)pt nil 
      p(list(/(+(car p1)(car p2))2)(/(+(cadr p1)(cadr p2))2))) 
      (foreach e2 s2 
        (setq obj(vlax-ename->vla-object e2) 
        d1(distance(vlax-curve-getClosestPointTo obj p)p) 
        d2(distance(vlax-curve-getClosestPointTo obj p t)p) 
        pt(append pt(list(list d1 d2 e2))))) 
      (setq e1(nth 2(car(vl-sort pt(function(lambda(e1 e2)(<(car e1)(car e2))))))) 
      e2(nth 2(car(vl-sort pt(function(lambda(e1 e2)(<(cadr e1)(cadr e2)))))))) 
      (setq e nil) 
      (if(/= e1 e2)(progn(command"zoom""C" p(/(getvar"VIEWSIZE")2)) 
         (while(null e)(setq e(entsel"\n无法确定与该文字对应的注记线,需要你来确定"))) 
         (setq e(car e)) 
         (command"zoom""p")) 
        (setq e e1)) 
      (setq e1(vlax-ename->vla-object e) 
      q1(vlax-curve-getstartPoint e1) 
      q2(vlax-curve-getendPoint e1) 
      e(entget e)) 
      (if(>(-(cadr p1)(cadr q1))(-(cadr p1)(cadr q2))) 
        (setq p q1 y(cadr q2)) 
        (setq p q2 y(cadr q1))) 
      (setq pt(list(list (car p1)y)(list(car p2)y)p)) 
      (foreach e1 e 
        (if(=(car e1)10) (setq p(car pt)e(subst(list 10(car p)(cadr p))e1 e)pt(vl-remove p pt)))) 
      (entmod e) 
      ))) 
  )

;;命令你可以改成你需要的，运行时会先把图层全部列出来，让你输入你将要处理的对象所在的图层，然后会叫你指定两个框选点，接下来根据那两个点选定你先前所给图层上的文字和多线段进行处理
;;要求线只能是LWPOLYLINE, 对于POLYLINE没有弄，如果实在需要，可以进一步完善，希望能达到你的要求

ZZXXQQ · 发表于 2013-5-21 08:35:25

如果直接用ACAD自带的LEADER就没有这个问题。

fire9527 · 发表于 2013-5-21 13:25:19

ZZXXQQ 发表于 2013-5-21 08:35
如果直接用ACAD自带的LEADER就没有这个问题。

这个倒是，主要是现在要调整别人的图，修改大量编号，图中的编号下面是PL线，不是LEADER

有劳大侠帮我想想办法

fire9527 · 发表于 2013-10-26 08:29:10

llsheng_73 发表于 2013-10-25 18:22
郁闷，给你弄了小半天，最后要回复的时候找不到这个帖子了，东找西找眼睛都看花了才找到地方

;;命 ...

大侠，程序运行结果是出现一个本图中存在的图层列表哦

llsheng_73 · 发表于 2013-10-26 11:11:44

本帖最后由 llsheng_73 于 2013-10-26 11:15 编辑

fire9527 发表于 2013-10-26 08:29
大侠，程序运行结果是出现一个本图中存在的图层列表哦

为了你那些东东不一定在固定的图层，所以叫你根据那个图层名列表去输入图层名，然后继续运行
如果写成固定图层了，那不是图层万一变化了那不是又得改它?

你还可以根据这种办法给线指定一个图层，那样你的注记文字就可以和引线不一定非要在同一图层了，当然需要的话你完全可以自己进行修改

spp_wall · 发表于 2013-12-2 17:27:15

llsheng_73 发表于 2013-10-26 11:11
为了你那些东东不一定在固定的图层，所以叫你根据那个图层名列表去输入图层名，然后继续运行
如果写成固 ...

为什么我用起来不行呢？

llsheng_73 · 发表于 2013-12-2 17:31:42

本帖最后由 llsheng_73 于 2013-12-2 20:23 编辑

spp_wall 发表于 2013-12-2 17:27
为什么我用起来不行呢？

那是根据别人的需求写的，不是自己设计的，那根线只能是PLINE出来的线并且假定它和文字在同一图层
你这个有可能它不是单独的线，难道跟文字是一个块？或者图层锁定？根据你的图上看最大可能是线与文字不在同一图层的可能性更大

spp_wall · 发表于 2013-12-2 17:50:39

llsheng_73 发表于 2013-12-2 17:31
那是根据别人的需求写的，不是自己设计的，那根线只能是PLINE出来的线
你这个有可能它不是单独的线，难道 ...

了解！！！！！！！！

fire9527 · 发表于 2014-4-15 19:25:39

llsheng_73 发表于 2013-5-19 14:26
郁闷，给你弄了小半天，最后要回复的时候找不到这个帖子了，东找西找眼睛都看花了才找到地方

;;命 ...

大侠，程序用了一段时间，以前还比较适用，现在图层多了，每次输入图层好麻烦啊，还是想麻烦你帮我加一些定义好的图层（标注文字和标注线所在的那些图层），希望能继续帮我，谢谢！

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

求一个能自动调整文字下方PL线长度的程序

最佳答案

相关帖子

自动调整文字下引线长度以适合文字长度

评分

本帖子中包含更多资源