求高手帮忙，批量生成中线
小弟初学lisp，会只找出两条线中线的办法，求高手帮忙搞定批量生成程序，感激不尽。以下是生成中线的部分代码和测试图
(defun c:tt()
(setq ssL (ssget '((0 . "LINE"))))
;;下面取出两条线的坐标
;;;此处加入判断是否选择了两根梁线
;;;下面取得两条梁线的四个端点
(if (= (sslength SSL) 2)
(progn
(setq pt1 (cdr (assoc 10 (entget (ssname ssL 0))))
pt2 (cdr (assoc 11 (entget (ssname ssL 0))))
pt3 (cdr (assoc 10 (entget (ssname ssL 1))))
pt4 (cdr (assoc 11 (entget (ssname ssL 1))))
ang1 (/ (* (vla-get-angle(vlax-ename->vla-object(ssname ssL 0))) 180) pi);;;直线1的角度
ang2 (/ (* (vla-get-angle(vlax-ename->vla-object(ssname ssL 1))) 180) pi);;;直线2的角度
)
)
;;;增加错误函数
);end if
;;;m1,m2为两条直线中心线的两端点
(setq m1 (list (/ (+ (car pt1) (car pt3)) 2) (/ (+ (cadr pt1) (cadr pt3)) 2)))
(setq m2 (list (/ (+ (car pt2) (car pt4)) 2) (/ (+ (cadr pt2) (cadr pt4)) 2)))
(if (and
(= (rtos (car m1) 2 4) (rtos (car m2) 2 4))
(= (rtos (cadr m1) 2 4) (rtos (cadr m2) 2 4))
(= (rtos (last m1) 2 4) (rtos (last m2) 2 4))
)
(progn
(setq pt10 pt1)
(setq pt1 pt2)
(setq pt2 pt10)
(setq m1 (list (/ (+ (car pt1) (car pt3)) 2) (/ (+ (cadr pt1) (cadr pt3)) 2)))
(setq m2 (list (/ (+ (car pt2) (car pt4)) 2) (/ (+ (cadr pt2) (cadr pt4)) 2)))
)
)
)
同求，为楼主顶一下 测试图太片面,最好是从工作底图上截下的,未说明规则,太笼统,不好办. 看帖就回，顶起来让高手出招偷学 中心线的好像就可以 http://bbs.mjtd.com/forum.php?mod=viewthread&tid=90482
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=90617 可以换个思路,画出中心线,用双向偏移,得到平行线.这样可以多选. 本帖最后由 004 于 2013-1-9 14:50 编辑
(defun c:tt (/ 2PI 3/4PI A ANG B BANGBENDBST
END LST MID PI/2SS SSMID SSPT1 SSPT2 ST
)
;;添加直线中心线 2013-01-09
(setvar "osmode" 0)
(setq pi/2 (/ pi 2))
(setq 2pi (* 2 pi))
(setq 3/4pi (/ (* 3 pi) 4))
(defun sjzl (e / ANG EL END ST TMP)
(setq el (entget e))
(setq st (cdr (assoc 10 el)))
(setq st (list (car st) (cadr st)))
(setq end (cdr (assoc 11 el)))
(setq end (list (car end) (cadr end)))
(setq ang (angle st end))
(cond ((or (= ang 0) (= ang pi) (= ang 2pi))
(progn (setq ang 0)
(if (> (car st) (car end))
(setq tmp st
stend
end tmp
)
)
)
)
((or (= ang pi/2) (= ang 3/4pi))
(progn (setq ang pi/2)
(if (> (cadr st) (cadr end))
(setq tmp st
stend
end tmp
)
)
)
)
((> ang pi)
(progn (setq ang (- ang pi)
tmp st
stend
end tmp
)
)
)
)
(list st end ang)
)
(setq ss (ssget "x" '((0 . "LINE") (8 . "BEAM"))))
(while (> (sslength ss) 0)
(setq a (ssname ss 0))
(setq lst (sjzl a))
(setq st (car lst))
(setq end (cadr lst))
(setq ang (caddr lst))
(setq mid (mapcar (function (lambda (a b) (/ (+ a b) 2))) st end))
(setq sspt1 (polar mid (+ ang (/ pi 2)) 400)) ;选取长度
(setq sspt2 (polar mid (- ang (/ pi 2)) 400))
;;; (command "pline" sspt1 sspt2 "")
(command ".zoom" "w" sspt1 sspt2)
(setq ssmid
(ssget "f" (list sspt1 sspt2) '((0 . "LINE") (8 . "BEAM")))
)
(if (= (sslength ssmid) 2)
(progn
(ssdel a ssmid)
(ssdel a ss)
(setq b (ssname ssmid 0))
(setq lst (sjzl b))
(setq bst (car lst))
(setq bend (cadr lst))
(setq bang (caddr lst))
(if (equal ang bang 0.01)
(progn
(ssdel b ss)
(setq st
(mapcar (function (lambda (a b) (/ (+ a b) 2))) st bst)
)
(setq end (mapcar (function (lambda (a b) (/ (+ a b) 2)))
end
bend
)
)
(entmake (list '(0 . "LINE") (cons 10 st) (cons 11 end)))
)
)
)
(ssdel a ss)
)
)
(princ)
)
页:
[1]
2