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 (/   enten      pt   enname
      p1   p2ang ptemp1 p0   pt1
      sp   source ptemp ptemp1 ptemp2 ptemp3
      pt1   pt2pt3 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

<p>呵呵，很好！</p>

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

<p><font face="Verdana">谢谢楼上兄弟的分享，参考下，非常感激！</font></p>

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

不错，很好
页: [1] 2
查看完整版本: [原创]动态绘制垂直平分线