;;; ****************************************************************
;;; 轴断面绘制
;;; ****************************************************************
(defun c:zdm (/ #erryx001 $orr code cp curve d en ent gr i la loop lst name name1 norm obj p p0 p00 p1 p10 p11 p2 p20 p21 p3
		p4 pp pt r r1 r2 snap ss ty x
	     )
  (defun #erryx001 (s)
    (if name1
      (redraw name1 4)
    )
    (command ".UNDO" "E")
    (setvar "osmode" snap)
    (setq *error* $orr)
  )
  (defun hh:pickarc (curve p / pp)
    (setq pp (vlax-curve-getclosestpointto curve (trans p 1 0)))
    (setq pp (vlax-curve-getsecondderiv curve (fix (vlax-curve-getparamatpoint curve pp))))
    (equal pp '(0.0 0.0 0.0))
  )
  (defun pertoline (cp p1 p2 / norm)
    (setq norm (mapcar
		 '-
		 p2
		 p1
	       )
	  p1 (trans p1 0 norm)
	  cp (trans cp 0 norm)
    )
    (trans (list (car p1) (cadr p1) (caddr cp)) norm 0)
  )
  (defun rf (r / pp)
    (* (/ r 180.0) pi)
  )
  (vl-load-com)
  (setvar "cmdecho" 0)
  (setq snap (getvar "osmode"))
  (setq $orr *error*)
  (setq *error* #erryx001)
  (command ".UNDO" "BE")
  (if (setq en (entsel "\n选择第一条直线:"))
    (progn
      (setq name (car en)
	    name1 name
	    p0 (cadr en)
	    p0 (osnap p0 "_NEA")
	    ent (entget name)
	    ty (cdr (assoc 0 ent))
	    la (assoc 8 ent)
      )
      (redraw name1 3)
      (if (= ty "LWPOLYLINE")
	(if (hh:pickarc name p0)
	  (progn
	    (setq lst '()
		  obj (vlax-ename->vla-object name)
		  i (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj p0)))
	    )
	    (foreach x ent
	      (if (= (car x) 10)
		(setq lst (cons (cdr x) lst))
	      )
	    )
	    (setq lst (reverse lst)
		  p10 (nth i lst)
		  p11 (nth (if (< (1+ i) (length lst))
			     (1+ i)
			     0
			   ) lst
		      )
		  ty "LINE"
	    )
	  )
	)
	(if (= ty "LINE")
	  (setq p10 (cdr (assoc 10 ent))
		p11 (cdr (assoc 11 ent))
	  )
	)
      )
      (setq r1 (angle p10 p11))
      (if (= ty "LINE")
	(progn
	  (princ "\n选择第二条平行直线:")
	  (setq loop t)
	  (while loop
	    (setq gr (grread t 15 2)
		  code (car gr)
		  pt (cadr gr)
	    )
	    (cond
	      ((= code 5)	       ; 鼠标移动
		(redraw)
		(if (and
		      (setq p00 (osnap pt "_NEA"))
		      (setq ss (ssget "c" p00 p00))
		    )
		  (progn
		    (setq name (ssname ss 0)
			  ent (entget name)
			  ty (cdr (assoc 0 ent))
		    )
		    (if (= ty "LWPOLYLINE")
		      (if (hh:pickarc name p00)
			(progn
			  (setq lst '()
				obj (vlax-ename->vla-object name)
				i (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj p00)))
			  )
			  (foreach x ent
			    (if (= (car x) 10)
			      (setq lst (cons (cdr x) lst))
			    )
			  )
			  (setq lst (reverse lst)
				p20 (nth i lst)
				p21 (nth (if (< (1+ i) (length lst))
					   (1+ i)
					   0
					 ) lst
				    )
				ty "LINE"
			  )
			)
		      )
		      (if (= ty "LINE")
			(setq p20 (cdr (assoc 10 ent))
			      p21 (cdr (assoc 11 ent))
			)
		      )
		    )
		    (if (= ty "LINE")
		      (progn
			(setq r2 (angle p10 p11))
			(if (not (inters
				   p10
				   p11
				   p20
				   p21
				   nil
				 )
			    )
			  (progn
			    (setq p1 (pertoline p00 p10 p11))
			    (grvecs (list 1 p00 p1))
			  )
			)
		      )
		    )
		  )
		)
	      )
	      ((= code 3)	       ; 鼠标左键
		(redraw)
		(if (and
		      (setq p00 (osnap pt "_NEA"))
		      (setq ss (ssget "c" p00 p00))
		    )
		  (progn
		    (setq name (ssname ss 0)
			  ent (entget name)
			  ty (cdr (assoc 0 ent))
		    )
		    (if (= ty "LWPOLYLINE")
		      (if (hh:pickarc name p00)
			(progn
			  (setq lst '()
				obj (vlax-ename->vla-object name)
				i (fix (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj p00)))
			  )
			  (foreach x ent
			    (if (= (car x) 10)
			      (setq lst (cons (cdr x) lst))
			    )
			  )
			  (setq lst (reverse lst)
				p20 (nth i lst)
				p21 (nth (if (< (1+ i) (length lst))
					   (1+ i)
					   0
					 ) lst
				    )
				ty "LINE"
			  )
			)
		      )
		      (if (= ty "LINE")
			(setq p20 (cdr (assoc 10 ent))
			      p21 (cdr (assoc 11 ent))
			)
		      )
		    )
		    (if (= ty "LINE")
		      (progn
			(setq r2 (angle p10 p11))
			(if (not (inters
				   p10
				   p11
				   p20
				   p21
				   nil
				 )
			    )
			  (progn
			    (setq loop nil)
			    (setvar "osmode" 0)
			    (setq p1 (pertoline p00 p10 p11))
			    (setq d (distance p00 p1))
			    (setq r (/ (* 0.25 d) (cos (rf 50))))
			    (setq p2 (polar p00 (angle p00 p1) (* 0.5 d)))
			    (setq p3 (polar p2 r1 (* 0.15 d)))
			    (setq p4 (polar p3 (+ r1 (rf 140)) r))
			    (entmake (list '(0 . "ARC") '(62 . 4) (cons 10 p4) (cons 40 r) (cons 50 (- r1 (rf 40)))
					   (cons 51 (+ r1 (rf 40)))
				     )
			    )
			    (setq p4 (polar p3 (+ r1 (rf 40)) r))
			    (entmake (list '(0 . "ARC") '(62 . 4) (cons 10 p4) (cons 40 r) (cons 50 (+ r1 (rf 140)))
					   (cons 51 (- r1 (rf 140)))
				     )
			    )
			    (setq p4 (polar p3 (- r1 (rf 40)) r))
			    (entmake (list '(0 . "ARC") '(62 . 4) (cons 10 p4) (cons 40 r) (cons 50 (+ r1 (rf 140)))
					   (cons 51 (- r1 (rf 140)))
				     )
			    )
			    (command "-hatch" "P" "ANSI31" (rtos (* 0.01 d)) "0" (polar p3 (+ r1 (* 0.5 pi)) (* 0.25 d)) "")
			    (setq p3 (polar p2 r1 (* -0.15 d)))
			    (setq p4 (polar p3 (- r1 (rf 40)) r))
			    (entmake (list '(0 . "ARC") '(62 . 4) (cons 10 p4) (cons 40 r) (cons 50 (+ r1 (rf 140)))
					   (cons 51 (- r1 (rf 140)))
				     )
			    )
			    (setq p4 (polar p3 (+ r1 (rf 140)) r))
			    (entmake (list '(0 . "ARC") '(62 . 4) (cons 10 p4) (cons 40 r) (cons 50 (- r1 (rf 40)))
					   (cons 51 (+ r1 (rf 40)))
				     )
			    )
			    (setq p4 (polar p3 (- r1 (rf 140)) r))
			    (entmake (list '(0 . "ARC") '(62 . 4) (cons 10 p4) (cons 40 r) (cons 50 (- r1 (rf 40)))
					   (cons 51 (+ r1 (rf 40)))
				     )
			    )
			    (command "trim" "" "F" (polar p2 (+ r1 (* 0.5 pi)) (* 0.49 d)) (polar p2 (+ r1 (* 0.5 pi))
												  (* 0.51 d)
											   ) "" "F" (polar p2 (- r1
														 (* 0.5 pi)
													      ) (* 0.49 d)
												    ) (polar p2 (- r1
														   (* 0.5 pi)
														) (* 0.51 d)
												      ) "" ""
			    )
			    (command "-hatch" "P" "ANSI31" (rtos (* 0.01 d)) "0" (polar p3 (- r1 (* 0.5 pi)) (* 0.25 d)) "")
			    (setvar "osmode" snap)
			  )
			)
		      )
		    )
		  )
		)
	      )
	      ((member code '(11 25))  ; 鼠标右击
		(redraw)
		(setq loop nil)
	      )
	    )
	  )
	)
      )
      (redraw name1 4)
    )
  )
  (command ".UNDO" "E")
  (setq *error* $orr)
  (princ)
)