[原创]动态绘制垂直平分线

xianaihua · 发表于 2009-12-22 19:00:00

本帖最后由作者于 2009-12-22 21:42:43 编辑

编写了一个动态绘制垂直平分线的程序，请各位朋友试用

;;;;动态绘制垂直平分线
;;;by:lihuili 2009-12-20
;;;Dynamic drawing a line to another line perpendicular bisector
(defun Perp_bisector_line (/ ent en pt enname
p1 p2 ang ptemp1 p0 pt1
sp source ptemp ptemp1 ptemp2 ptemp3
pt1 pt2 pt3 loop
)
(setvar "cmdecho" 0)
(if (and (setq ent (car (entsel "\n选择一条直线.")))
(= (cdr (assoc 0 (setq en (entget ent)))) "LINE")
)
(progn
(redraw ent 3)
(setq p1 (trans (cdr (assoc 10 en)) 0 1)
p2 (trans (cdr (assoc 11 en)) 0 1)
ang (angle p1 p2)
)
(setq p0 (polar p1 ang (* 0.5 (distance p1 p2)))
lineobj (vla-addLine
(vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(vlax-3d-point p0)
(vlax-3d-point p0)
)
)
(setq ptemp1 (polar p0 (+ ang (* 0.5 pi)) 10))
(prompt "\n选择另一端点位置:")
(setq loop t
ptemp p0
pt1 p0
)
(while loop
(setq sp (grread t))
(setq source (car sp)
sp (cadr sp)
)
(cond ((= source 5)
(setq ptemp sp)
(setq ptemp2 (polar sp 0 10)
ptemp3 (polar sp (* 0.5 pi) 10)
)
(setq pt2 (inters p0 ptemp1 sp ptemp2 nil))
(setq pt3 (inters p0 ptemp1 sp ptemp3 nil))
(cond ((null pt2) (setq pt1 pt3))
((null pt3) (setq pt1 pt2))
(t
(if (< (distance sp pt2) (distance sp pt3))
(setq pt1 pt2)
(setq pt1 pt3)
)
)
)
(vla-put-EndPoint lineobj (vlax-3d-point pt1))
)
(t (setq loop nil))
)
)
(redraw ent 4)
)
(prompt "\n选择的不是直线!")
)
(princ)
)
(defun c:test ()
(vl-load-com)
(Perp_bisector_line)
)

;;;;动态绘制垂直平分线
;;;by:lihuili 2009-12-20
;;;Dynamic drawing a line to another line perpendicular bisector
(defun Perp_bisector_line (/   ent  en      pt     enname
      p1   p2  ang ptemp1 p0     pt1
      sp   source ptemp ptemp1 ptemp2 ptemp3
      pt1   pt2  pt3 loop
     )
  (setvar "cmdecho" 0)
  (if (and (setq ent (car (entsel "\n选择一条直线.")))
    (= (cdr (assoc 0 (setq en (entget ent)))) "LINE")
      )
    (progn
      (redraw ent 3)
      (setq p1 (trans (cdr (assoc 10 en)) 0 1)
     p2 (trans (cdr (assoc 11 en)) 0 1)
     ang (angle p1 p2)
      )
      (setq p0     (polar p1 ang (* 0.5 (distance p1 p2)))
     lineobj (vla-addLine
        (vla-get-ModelSpace
   (vla-get-ActiveDocument (vlax-get-acad-object))
        )
        (vlax-3d-point p0)
        (vlax-3d-point p0)
      )
      )

(setq ptemp1 (polar p0 (+ ang (* 0.5 pi)) 10))
      (prompt "\n选择另一端点位置:")
      (setq loop t
     ptemp p0
     pt1 p0
      )
      (while loop
 (setq sp (grread t))
 (setq source (car sp)
       sp     (cadr sp)
 )
 (cond ((= source 5)
        (setq ptemp sp)
        (setq ptemp2 (polar sp 0 10)
       ptemp3 (polar sp (* 0.5 pi) 10)
        )
        (setq pt2 (inters p0 ptemp1 sp ptemp2 nil))
        (setq pt3 (inters p0 ptemp1 sp ptemp3 nil))
        (cond ((null pt2) (setq pt1 pt3))
       ((null pt3) (setq pt1 pt2))
       (t
        (if (< (distance sp pt2) (distance sp pt3))
   (setq pt1 pt2)
   (setq pt1 pt3)
        )
       )
        )
        (vla-put-EndPoint lineobj (vlax-3d-point pt1))
       )
       (t (setq loop nil))
 )
      )
      
      (redraw ent 4)
    )
    (prompt "\n选择的不是直线!")
  )
  (princ)
)

(defun c:test ()
(vl-load-com)
  (Perp_bisector_line)
)

xyz2009xyz · 发表于 2010-8-7 11:52:00

呵呵，很好！

xyp1964 · 发表于 2010-8-7 20:59:00

垂直平分线：

;;; czpfx(垂直平分线)
(defun c:czpfx (/ s1 pt rad)
(CMDLA0)
(setvar "osmode" 0)
(if (and (setq s1 (car (entsel "\n选择曲线: ")))
(xyp-curve-check s1)
)
(progn
(xyp-MkLaCo "垂直平分线" 1)
(setq pt (xyp-get-CurveMidPoint s1)
rad (xyp-get-AngleAtPoint s1 pt)
)
(setvar "snapang" rad)
(setvar "ORTHOMODE" 1)
(command "line" pt pause "")
(setvar "snapang" 0)
)
)
(CMDLA1)
)

dkj0322 · 发表于 2010-10-9 15:35:00

谢谢楼上兄弟的分享，参考下，非常感激！

yueyun · 发表于 2010-10-18 18:51:00

太强了，正在研究动态线，正好参考

zhangzl · 发表于 2012-3-14 14:14:42

不错，很好

自贡黄明儒 · 发表于 2012-3-14 14:32:34

如果曲线是块中曲线呢?

yoyoho · 发表于 2012-3-14 15:10:16

感谢xianaihua及xyp1964版主分享程序!

zhangzl · 发表于 2012-3-15 08:41:56

调试不行啊

zhangzl · 发表于 2012-3-15 08:41:56

不错，很好

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

[原创]动态绘制垂直平分线

本帖子中包含更多资源

本帖子中包含更多资源

点评

浏览过的版块