Try, to be completed with the error handling.
;;; Hatch between two polylines.
;;; Gian Paolo Cattaneo - 14.09.2013
(defun c:TesT ( / cmd e3 e3_ e3p e3p_ npar p_vert ListaV ListaVp LPint contorno_trat)
(or cal (arxload "geomcal"))
(vl-load-com)
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(if (and
(setq e3 (car (entsel "\nSelect First Polyline (GREEN) ")))
(setq e3_ (vlax-ename->vla-object e3))
(vl-position (vlax-get e3_ 'ObjectName) '("AcDbPolyline" "AcDb2dPolyline" ))
(not (redraw e3 3))
(setq e3p (car (entsel "\nSelect Second Polyline (RED) ")))
(setq e3p_ (vlax-ename->vla-object e3p))
(vl-position (vlax-get e3p_ 'ObjectName) '("AcDbPolyline" "AcDb2dPolyline" ))
(not (redraw e3 4))
(not (eq e3 e3p))
)
(progn
;;; poly1
(repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3))))
(setq p_vert (vlax-curve-getpointatparam e3 (setq n_par (1- n_par))))
(setq ListaV (cons p_vert ListaV))
)
(if (> (car (car ListaV)) (car (last ListaV))) (setq ListaV (reverse ListaV)))
;;; poly2
(repeat (setq n_par (1+ (fix (vlax-curve-getendparam e3p))))
(setq p_vert (vlax-curve-getpointatparam e3p (setq n_par (1- n_par))))
(setq ListaVp (cons p_vert ListaVp))
)
(if (> (car (car ListaVp)) (car (last ListaVp))) (setq ListaVp (reverse ListaVp)))
(lista_punti_intersezione)
(repeat (1- (length LPint))
(setq p- (car LPint))
(setq p+ (cadr LPint))
(calcolo_contorno_tratteggio)
(calcolo_tipo_area)
(disegno_hatch)
(setq LPint (cdr LPint))
)
)
)
(prompt "\n ") (prompt "\n ")
(command "_.undo" "_end")
(setvar 'cmdecho cmd)
(princ)
)
;;; Returns the intersection points of polylines.
(defun lista_punti_intersezione (/ INT)
(setq INT (vlax-invoke e3_ 'IntersectWith e3p_ acExtendNone))
(if INT
(progn
(repeat (/ (length INT) 3)
(setq LPint (cons (list (car INT)(cadr INT)(caddr INT)) LPint))
(setq INT (cdddr INT))
)
;Sort the list from left to right
(setq LPint
(vl-sort LPint
(function (lambda (x1 x2) (< (car x1) (car x2))))
) )
)
)
(if (< (length LPint) 2)
(progn
(alert "The polylines do not intersect in at least two points.")
(exit)
) )
)
;;; Returns a list of boundary points of the area to be hatched
(defun calcolo_contorno_tratteggio (/ x P_trat_esist P_trat_prog Dp- Dp+ )
;First polyline
(setq Dp- (vlax-curve-getDistAtPoint e3 p-))
(setq Dp+ (vlax-curve-getDistAtPoint e3 p+))
(mapcar
'(lambda (x) (if (and
(> (vlax-curve-getDistAtPoint e3 x) 1e-6)
(> (vlax-curve-getDistAtPoint e3 x) Dp-)
(< (vlax-curve-getDistAtPoint e3 x) Dp+)
)
(setq P_trat_esist (cons x P_trat_esist))
) )
ListaV
)
(setq P_trat_esist (reverse P_trat_esist))
;Second polyline
(setq Dp- (vlax-curve-getDistAtPoint e3p p-))
(setq Dp+ (vlax-curve-getDistAtPoint e3p p+))
(mapcar
'(lambda (x) (if (and
(> (vlax-curve-getDistAtPoint e3p x) 1e-6)
(> (vlax-curve-getDistAtPoint e3p x) Dp-)
(< (vlax-curve-getDistAtPoint e3p x) Dp+)
)
(setq P_trat_prog (cons x P_trat_prog))
) )
ListaVp
)
(setq P_trat_prog (reverse P_trat_prog))
;Hatch boundary
(setq contorno_trat (append (cons p- P_trat_esist) (list p+)))
(repeat (setq n (length P_trat_prog))
(setq contorno_trat (append contorno_trat (list (nth (setq n (1- n)) P_trat_prog))))
)
)
;;;Return the hatch color
(defun calcolo_tipo_area (/ p_sx apex p_esist p_prog)
(setq p_sx (list (- (car p-) 1.0) (cadr p-)))
(setq apex p-)
(setq p_esist (cadr contorno_trat))
(setq p_prog (last contorno_trat))
(if (> (cal "ang (apex, p_sx, p_esist)") (cal "ang (apex, p_sx, p_prog)"))
(setq col 4) (setq col 2)
)
)
;;;Hatch
(defun disegno_hatch (/ i hatch_def)
(setq contorno_trat (cons (last contorno_trat) contorno_trat))
(setq hatch_def (list
'(0 . "HATCH")
'(100 . "AcDbEntity")
'(67 . 0)
'(410 . "Model")
(cons 62 col)
'(100 . "AcDbHatch")
'(10 0.0 0.0 0.0)
'(210 0.0 0.0 1.0)
'(2 . "SOLID")
'(70 . 1)
'(71 . 0)
'(91 . 1)
'(92 . 1)
(cons 93 (1- (length contorno_trat)))
) )
(repeat (setq i (1- (length contorno_trat)))
(setq hatch_def
(append
hatch_def
(list '(72 . 1))
(list (cons 10 (nth i contorno_trat)))
(list (cons 11 (nth (setq i (1- i)) contorno_trat)))
)
)
)
(setq hatch_def
(append
hatch_def
(list '(97 . 0))
(list '(75 . 0))
(list '(76 . 1))
(list '(98 . 1))
(list '(10 0.0 0.0 0.0))
(list '(470 . "LINEAR"))
)
)
(entmake hatch_def)
(command "_.draworder" (entlast) "" "_b")
)