画斜坡 毫米单位图不支持圆弧
(defunmkxp ( pta jd /)(defun emkblk ( pt name / pt1 pt2 pt3 )
(entmake (list '(0 . "block") (cons 2 name) '(70 . 0) (cons 10 pt)))
(setq pt1(polar pt (* 1.5 pi )750 ))(setq pt2 (polar pt 0750 )) (setq pt3 (polar pt2 (* 1.5 pi )1500 ))
(entmake (list '(0 . "LINE") (cons 10 pt) (cons 11 pt1)))
(entmake (list '(0 . "LINE") (cons 10 pt2) (cons 11 pt3)))
(entmake '((0 . "ENDBLK")))
;(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))
)
(emkblk '(0 0) "GCpzx")
(entmake (list '(0 . "INSERT") (cons 2 "GCpzx") (cons 10 pta)(cons 50 jd)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun vxs (e / i v lst ppp)
(setq i 0)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(setq ppp (reverse lst) )
(append (list(vlax-curve-getpointatparam e 0)) ppp )
)
;;;;;;;;;;;;;;;;;;;;;
(defun c:hxp1000 ( /p1 plst zbb juli jiaodu i )
(vl-load-com)
(setq plst (vxs(car(entsel "\n 请选择坡顶线："))) )
(setq p1 nil)
(setq zbb (mapcar'list plst (cdr plst)) )
(foreach x zbb
(setq juli (distance (car x) (cadr x)))
(setq jiaodu (angle (car x) (cadr x) ))
(mkxp(car x) jiaodu )
(setq i 0)
(repeat (fix ( / juli 1500) )
(mkxp (polar (car x) jiaodu (* 1500 (1+ i) ))jiaodu )
(setq i (1+ i))
)
)
(princ)
)
收藏啦，感谢分享！ 还有缺陷（附图），另外每个线段都是单独的个体，不方便删除；
页:
[1]