(defun c:acir(/ circle _moveblk aDoc ss e ang pts ln p1 p2 cir1 cir2 entm_ entm gr code cord)
(if (not (member "geomcal.arx" (arx)))
(arxload "geomcal")
)
(setvar 'osmode 0)
(defun circle(Doc p r)
(vlax-invoke
(vlax-get (vla-get-ActiveLayout Doc) 'Block)
'AddCircle pr
)
)
(defun _moveblk(flg ent bp np)
(if (not flg)
(vla-move
(setq flg (vla-copy ent))
(vlax-3d-point bp)
(vlax-3d-point np)
)
(progn (vla-delete flg) (setq flg nil))
)
flg
)
(setq aDoc (vla-get-activedocument (vlax-get-acad-object)))
(if
(setq ss (ssget '((0 . "LINE"))))
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(redraw e 3)
(setq ang (apply 'angle
(setq pts(mapcar
'(lambda (d)
(cdr(assoc
d
(entget e))))
'(10 11))
)))
(if (> (setq ln (apply 'distance pts)) 12.0)
(progn
(redraw e 3)
(setq p1 (Car pts)
p2 (Cadr pts))
(setq cir1 (circle aDoc
(setq uPt1 (polar (vlax-curve-getPointAtDist
e 6.0) (+ ang (/ pi 2.)) 0.375))
0.1875))
(setq cir2 (circle aDoc
(setq uPt2 (polar (vlax-curve-getPointAtDist
e (- ln 6.0)) (+ ang (/ pi2.))0.375))
0.1875))
(prompt "\nDrag & Pick Location rebar location:")
(while
(progn
(setq gr (grread t 15 0)
code (car gr)
cord (cadr gr)
)
(cond
((and (= 5 code)(> (c:cal "ang(p1,p2,cord)") 180))
(setq entm (_moveblk entm cir1 uPt1
(setq uPt1 (polar uPt1 (+ ang (* pi 1.5)) 0.75))))
(setq entm_ (_moveblk entm_ cir2 uPt2
(setq uPt2 (polar uPt2 (+ ang (* pi 1.5)) 0.75)))) T
)
((and (= 5 code)(< (c:cal "ang(p1,p2,cord)") 180))
(setq entm (_moveblk entm cir1 uPt1
(setq uPt1 (polar uPt1 (+ ang (/ pi 2.)) 0))))
(setq entm_ (_moveblk entm_cir2uPt2
(setq uPt2 (polar uPt2 (+ ang (/ pi 2.)) 0)))) T
)
)
)
)
(vla-delete cir1)
(vla-delete cir2)
)
)(redraw e 4)(setq entm nil entm_ nil)
)
)(princ)
)(vl-load-com)
(princ)
如果长度小于12个单位，则不会处理这些线。
页:
1
[2]