[原创]：两线的中心线

sdwy19691229 · 发表于 2004-12-30 19:26:36

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

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

×

两线的中心线
(defun C:GSL (/  m os e1 en  en1 p1 p2 e2 em p3 p4 ang1 ang2
         L1 L2 x1 y1 x2 y2 x3 y3 x4 y4 xb yb pb pa ang3 p5
         p6 p7 p8 p9 p10 L3 e3 en3 p11 ang3 pc L4 pd p5 p6)
      (setq m:err *error* *error* *merr*)
      (setvar "cmdecho" 0)
      (command "UNDO" "G")
      (command "UCS" "W")
      (setq os (getvar "osmode"))
      (setvar "osmode" 0)
      (setq e1 (entsel "\n选择第一条线:"))
      (if (= e1 nil)(princ) (progn
      (setq en (cdr (assoc '0  (entget (car e1)) )))
      (if (/= en "LINE") (princ "\n---所选图元不是直线---")
      (progn
      (setq en1 (cdr (assoc '-1 (entget (car e1)))))
      (redraw en1 3)
      (setq p1 (cdr (assoc '10 (entget (car e1)))))
      (setq p2 (cdr (assoc '11 (entget (car e1)))))
      (setq e2 (entsel "\n选择第二条线:"))
      (if (= e2 nil)(princ) (progn
      (redraw en1 4)
      (setq em (cdr (assoc '0  (entget (car e2)) )))
      (if (/= em "LINE") (princ "\n---所选图元不是直线---")
      (progn
      (setq p3 (cdr (assoc '10 (entget (car e2)))))
      (setq p4 (cdr (assoc '11 (entget (car e2)))))
      (setq ang1 (angle p1 p2))
      (setq ang2 (angle p3 p4))
      (setq L1 (distance p1 p2))
      (setq L2 (distance p3 p4))
      (setq x1 (car p1))(setq y1 (cadr p1))
      (setq x2 (car p2))(setq y2 (cadr p2))
      (setq x3 (car p3))(setq y3 (cadr p3))
      (setq x4 (car p4))(setq y4 (cadr p4))
      (setq xb (/ (+ x1 x2 x3 x4) 4.0))
      (setq yb (/ (+ y1 y2 y3 y4) 4.0))
      (setq pb (list xb yb))
      (setq pa (inters  p1 p2 p3 p4 nil))
      (if (= pa nil)(progn
      (setq ang3 (angle p1 p2))
      (setq p5 (polar pb ang3 (/ (+ L1 L2) 4.0)))
      (setq p6 (polar pb (+ pi ang3) (/ (+ L1 L2) 4.0)))
      (command "LINE" p5 p6 "") )
      (progn
      (setq p7 (cadr e1))
      (setq p8 (cadr e2))
      (setq p9 (osnap p7 "nearest"))
      (setq p10 (osnap p8 "nearest"))
      (setq L3 (/ (distance p9 p10) 2.0))
      (command "Circle" "ttr" p9 p10 L3)
      (setq e3 (entlast))
      (setq en3 (cdr (assoc '-1 (entget e3))))
      (setq p11 (cdr (assoc '10 (entget e3))))
      (setq ang3 (angle pa p11))
      (entdel e3)
      (setq pc (inters  p1 p2 p3 p4))
      (if (= pc nil)(progn
      (setq L4 (distance pa pb))
      (setq pd (polar pa ang3 L4))
      (setq p5 (polar pd ang3 (/ (+ L1 L2) 4.0)))
      (setq p6 (polar pd (+ pi ang3) (/ (+ L1 L2) 4.0)))
      (command "LINE" p5 p6 "") )
      (progn
      (setq p5 pa)
      (setq p6 (polar pa ang3 (/ (+ L1 L2) 4.0)))
      (command "LINE" p5 p6 "")
      ))  ))
      ))  ))  ))  ))
      (setvar "osmode" os)
      (command "UCS" "P")
      (command "UNDO" "E")(princ) )

xyp1964 · 发表于 2004-12-30 22:47:06

两线端点连线之中点连线：
[php]
(defun C:test034 (/ en1 en2)
  (vl-load-com)
  (while (/= en1 "LINE")
(setq e1  (entsel "\n选择第1条线:")
   en1 (dxf 0 (entget (car e1)))
)
  )
  (while (/= en2 "LINE")
(setq e2  (entsel "\n选择第2条线:")
   en2 (dxf 0 (entget (car e2)))
)
  )
  (setq pt1 (vlax-curve-getstartPoint (car e1))
pt2 (vlax-curve-getendPoint (car e1))
pt3 (vlax-curve-getstartPoint (car e2))
pt4 (vlax-curve-getendPoint (car e2))
  )
  (if (or (and (<= (car pt1) (car pt2)) (<= (car pt3) (car pt4)))
   (and (>= (car pt1) (car pt2)) (>= (car pt3) (car pt4)))
   )
(setq pt5 (_midp pt1 pt3)
   pt6 (_midp pt2 pt4)
)
(setq pt5 (_midp pt1 pt4)
   pt6 (_midp pt2 pt3)
)
  )
  (command "LINE" pt5 pt6 "")
  (princ)
)
(defun _midp (p1 p2)
  (list (+ (/ (- (car p1) (car p2)) 2) (car p2))
(+ (/ (- (cadr p1) (cadr p2)) 2) (cadr p2))
  ))
(defun dxf (code elist) (cdr (assoc code elist)))
[/php]

sdwy19691229 · 发表于 2004-12-30 23:40:48

我也上传个图片！

lijiao · 发表于 2004-12-31 08:43:31

如果两条直线十字相交，中心线该放在那一边？
几个月前，我也上传了一个类似的程序，通过GRREAD动态指定中心线的方向和长度。

sdwy19691229 · 发表于 2004-12-31 13:02:56

选在哪边就靠哪边的，
不是点选图元的吗？

PFD8667 · 发表于 2005-1-2 10:25:27

楼上二位程序都好用,但有一个问题不是真正的中心线,应该叫作二线的中间线,因为我用的图层自动切换的应该是点划线才是中心线,而现在却是实线,请教二位能否修改一下那就好用了,比如一个矩形需标中心线,能用在实处,多谢了,

panzhongw · 发表于 2005-1-2 12:55:56

如果是PLINE呢？

xyp1964 · 发表于 2005-1-2 14:37:59

最初由 PFD8667 发布
[B]楼上二位程序都好用,但有一个问题不是真正的中心线,应该叫作二线的中间线,因为我用的图层自动切换的应该是点划线才是中心线,而现在却是实线,请教二位能否修改一下那就好用了,比如一个矩形需标中心线,能用在实处,多谢... [/B]

中心线程序（公布源码彻底免币）：
http://www.xdcad.net/forum/showthread.php?s=&threadid=313654

PFD8667 · 发表于 2005-1-2 15:52:54

谢谢xyp1964楼主提供的<中心线程序>,我不会编程,爱收集实用的程序,我想能解决二个问题就好了,一是对象捕捉没有了的问题,二是中心线长度应该是二分之一才对.我过分要求,有点不好意思,但总想有了你高手提供的好程序,应该完善就太好了,另外你定制的一个有二个文件不知如何用?是不是就加载zxx,fas就可以了,我试了一下,与第一个没什么区别,请指教,再次表示谢意!

sdwy19691229 · 发表于 2005-1-2 21:24:39

感谢6楼的建议，我将程序改了一下。
希望你能满意。

两线的中心线
(defun C:GSL (/  m os e1 en  en1 p1 p2 e2 em p3 p4 ang1 ang2
         L1 L2 x1 y1 x2 y2 x3 y3 x4 y4 xb yb pb pa ang3 p5
      p6 p7 p8 p9 p10 L3 e3 en3 p11 ang3 pc L4 pd p5 p6 La)
      (setq m:err *error* *error* *merr*)
      (setvar "cmdecho" 0)
      (command "UNDO" "G")
      (command "UCS" "W")
      (setq os (getvar "osmode"))
      (setvar "osmode" 0)
      (setq e1 (entsel "\n选择第一条线:"))
      (if (= e1 nil)(princ) (progn
      (setq en (cdr (assoc '0  (entget (car e1)) )))
      (if (/= en "LINE") (princ "\n---所选图元不是直线---")
      (progn
      (setq en1 (cdr (assoc '-1 (entget (car e1)))))
      (redraw en1 3)
      (setq p1 (cdr (assoc '10 (entget (car e1)))))
      (setq p2 (cdr (assoc '11 (entget (car e1)))))
      (setq e2 (entsel "\n选择第二条线:"))
      (if (= e2 nil)(princ) (progn
      (redraw en1 4)
      (setq em (cdr (assoc '0  (entget (car e2)) )))
      (if (/= em "LINE") (princ "\n---所选图元不是直线---")
      (progn
      (setq p3 (cdr (assoc '10 (entget (car e2)))))
      (setq p4 (cdr (assoc '11 (entget (car e2)))))
      (setq ang1 (angle p1 p2))
      (setq ang2 (angle p3 p4))
      (setq L1 (distance p1 p2))
      (setq L2 (distance p3 p4))
      (setq x1 (car p1))(setq y1 (cadr p1))
      (setq x2 (car p2))(setq y2 (cadr p2))
      (setq x3 (car p3))(setq y3 (cadr p3))
      (setq x4 (car p4))(setq y4 (cadr p4))
      (setq xb (/ (+ x1 x2 x3 x4) 4.0))
      (setq yb (/ (+ y1 y2 y3 y4) 4.0))
      (setq pb (list xb yb))
      (setq pa (inters  p1 p2 p3 p4 nil))
      (if (= pa nil)(progn
      (setq ang3 (angle p1 p2))
      (setq p5 (polar pb ang3 (/ (+ L1 L2) 4.0)))
      (setq p6 (polar pb (+ pi ang3) (/ (+ L1 L2) 4.0)))
      (command "LINE" p5 p6 "") )
      (progn
      (setq p7 (cadr e1))
      (setq p8 (cadr e2))
      (setq p9 (osnap p7 "nearest"))
      (setq p10 (osnap p8 "nearest"))
      (setq L3 (/ (distance p9 p10) 2.0))
      (command "Circle" "ttr" p9 p10 L3)
      (setq e3 (entlast))
      (setq en3 (cdr (assoc '-1 (entget e3))))
      (setq p11 (cdr (assoc '10 (entget e3))))
      (setq ang3 (angle pa p11))
      (entdel e3)
      (setq pc (inters  p1 p2 p3 p4))
      (if (= pc nil)(progn
      (setq L4 (distance pa pb))
      (setq pd (polar pa ang3 L4))
      (setq p5 (polar pd ang3 (/ (+ L1 L2) 4.0)))
      (setq p6 (polar pd (+ pi ang3) (/ (+ L1 L2) 4.0)))
      (command "LINE" p5 p6 "") )
      (progn
      (setq p5 pa)
      (setq p6 (polar pa ang3 (/ (+ L1 L2) 4.0)))
      (command "LINE" p5 p6 "")
      ))  ))
      (setq La (tblsearch "LAYER" "Center"))
      (if (= La nil)
      (command "-layer" "n" "Center" "c" "4" "Center" "lt" "center" "Center" ""))
      (command "chprop" "L" "" "la" "center" "")
      ))  ))  ))  ))
      (setvar "snapang" 0)
      (setvar "osmode" os)
      (command "UCS" "P")
      (command "UNDO" "E")(princ) )

xyp1964 · 发表于 2005-1-2 21:53:46

最初由 PFD8667 发布
[B]谢谢xyp1964楼主提供的<中心线程序>,我不会编程,爱收集实用的程序,我想能解决二个问题就好了,一是对象捕捉没有了的问题,二是中心线长度应该是二分之一才对.我过分要求,有点不好意思,但总想有了你高手提供的好程序,应... [/B]

不太明白为什么“中心线长度应该是二分之一”，“三分之一”……难道不行？
两个程序的区别在于可以输入或屏幕拾取。

PFD8667 · 发表于 2005-1-3 09:46:31

太谢谢sdwy19691229了,您将程序改了一下,使我感到太满意了.又实用,以后画轴中心线那太方便了,给您添麻烦了,我先当宝贝收藏了,不好意思该程序如果画矩形中心线时能比二线二端各长2毫米,那就可一次性标出标准的中心线了,我不懂编程,也许我不该怎么脸厚,就当我没说吧,我再次谢谢您了!

xotoo · 发表于 2008-8-9 03:34:29

我觉得这样的程序应该支持框选最好了——比如我做室内设计，画120厚的墙，画完后只有两条间距120的平行线，可是我下面的工作需要捕捉到这个120的中心线的位置进行相应的操作，那么能支持框选这两条线就最好了……

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

[原创]：两线的中心线

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子