刚刚随手编的一个相同文字连线的小程序

masterlong · 发表于 2015-1-20 23:14:34

刚刚随手编的一个相同文字连线的小程序
对某些同学或许有点用

现在的设备、工艺专业人员都挺偷懒
按规矩应该在设备编号旁边注明电功率等内容
现在是啥也不标就给个设备表
核对起来很费时
这个程序就是点设备表的文字
自动在所有相同的文字之间连上直线
程序很简单扩展空间很大

(setq *ent2obj* vlax-Ename->Vla-Object)

(defun c:tt()
 (if (setq ss (ssget ":e:s" '((0 . "TEXT"))))
 (progn
(setq ttent (ssname ss 0))
(command "layer" "m" "f_temp_文字连线" "c" "6" "" "")
(setq str (cdr (assoc 1 (entget ttent))))
(setq po (getmidpo (entbox ttent)))
(setq ss (ssget "x" (list '(0 . "TEXT")(cons 1 str))))
(if (< 1 (sslength ss))
(progn
 (setq oldliness (ssget "x" '((0 . "line")(8 . "f_temp_文字连线"))))
 (if oldliness (command "erase" oldliness ""))

 (setq ss (vl-remove ttent (ss2list ss)))
 (foreach x ss
 (setq px (getmidpo (entbox x)))
 (command "line" "non" po "non" px "")
 )
)
(command "change" ttent "" "p" "co" "2" "")
)
 )
)
(princ)
)

;;单个物体的最小（正交）包围框
(defun entbox ( ent / ll ur )
(vla-getboundingbox (*ent2obj* ent) 'll 'ur)
(mapcar 'vlax-safearray->list (list ll ur))
)

;;求两点中点
(defun getmidpo( pts / P1 P2 X Y )
(setq p1 (car pts) p2 (cadr pts))
(if (= (length p1) (length p2))
 nil
 (setq p1 (list (car p1) (cadr p1))
p2 (list (car p2) (cadr p2))
 )
)
(mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)
)

;;选择集转为图元列表
(defun ss2list( ss )
(if (= 'PICKSET (type ss))
 (reverse (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss))))
)
)

xyp1964 · 发表于 2024-9-20 14:07:03

本帖最后由 xyp1964 于 2024-9-20 14:08 编辑

(defun c:tt ()
"相同文字连线"
(defun Ep5 (e / p1 p9 p)
(vla-getboundingbox (vlax-Ename->Vla-Object e) 'p1 'p9)
(setq p(mapcar 'vlax-safearray->list (list p1 p9)))
(mapcar '(lambda (x y) (/ (+ x y) 2.0))(car p)(cadr p))
)
(defun ss2list (ss)
(vl-remove-if'(lambda (x) (/= (type x) 'ENAME))(mapcar 'cadr (ssnamex ss)))
)
(if (and (setq ss1 (ssget ":e:s" '((0 . "TEXT"))))
(setq s1 (ssname ss1 0))
(setq tx (cdr (assoc 1 (entget s1))))
(setq ss (ssget (list '(0 . "TEXT") (cons 1 tx))))
)
(progn
(command "-layer" "m" "文字连线" "c" "6" "" "")
(setq p0 (Ep5 s1)
lst (vl-remove s1 (ss2list ss))
)
(foreach x lst (command "line" "non" p0 "non" (Ep5 x) ""))
(princ "\n相同文本数量 = ")
(princ (length lst))
(alert (strcat "\n相同文本数量 = "(itoa (length lst))))
)
)
(princ)
)

(defun c:tt () 
  "相同文字连线" 
  (defun Ep5 (e / p1 p9 p) 
    (vla-getboundingbox (vlax-Ename->Vla-Object e) 'p1 'p9) 
    (setq p(mapcar 'vlax-safearray->list (list p1 p9))) 
    (mapcar '(lambda (x y) (/ (+ x y) 2.0))(car p)(cadr p)) 
  ) 
  (defun ss2list (ss) 
    (vl-remove-if'(lambda (x) (/= (type x) 'ENAME))(mapcar 'cadr (ssnamex ss))) 
  ) 
  (if (and (setq ss1 (ssget ":e:s" '((0 . "TEXT")))) 
           (setq s1 (ssname ss1 0)) 
           (setq tx (cdr (assoc 1 (entget s1)))) 
           (setq ss (ssget (list '(0 . "TEXT") (cons 1 tx)))) 
      ) 
    (progn 
      (command "-layer" "m" "文字连线" "c" "6" "" "") 
      (setq p0  (Ep5 s1) 
            lst (vl-remove s1 (ss2list ss)) 
      ) 
      (foreach x lst (command "line" "non" p0 "non" (Ep5 x) "")) 
      (princ "\n相同文本数量 = ") 
      (princ (length lst)) 
      (alert (strcat "\n相同文本数量 = "(itoa (length lst)))) 
    ) 
  ) 
  (princ) 
)

偶尔郁闷 · 发表于 2022-10-26 09:36:34

up

儒门小客 · 发表于 2024-9-18 23:41:46

非常感谢分享,局部修改可以实现天正文字连线

USER2128 · 发表于 2015-1-21 08:32:01

楼主可参考“http://bbs.mjtd.com/thread-110686-1-1.html”、http://bbs.xdcad.net/thread-678605-1-1.html

434939575 · 发表于 2015-1-21 09:48:33

这个挺好的

doro · 发表于 2015-1-21 12:30:47

这个还挺实用

伪书虫86 · 发表于 2015-1-21 13:02:10

谢谢龙前辈，这个挺好，以前找不到，都是用查找的，用这个就方便多了

zhengchuan · 发表于 2015-1-21 19:02:00

好工具。如果在连线前可以选择范围就更好啦。

小灰345 · 发表于 2015-1-21 19:48:54

学习了！！！！！

lyqiezi · 发表于 2015-1-21 22:41:07

我是用遍历zoom的方式，检查某个编号构件跟表格的是否一致

zhengchuan · 发表于 2015-1-22 10:54:05

能不能加个连线的框选范围啊

无花老和尚 · 发表于 2015-1-23 00:29:50

能不能连块啊

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

[源码] 刚刚随手编的一个相同文字连线的小程序

相关帖子

本帖子中包含更多资源