Label Contours
;;; 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")
)
Molto buono! Gian Paolo,
No need to call (geomcal.arx) - added (ListClockwise-p) subfunction for checking side of boundary polylines and assign correct color... Also added error handler - really simple one, and also make better formatting of code - it's more readable... Also checked for unlocalized variables n_par instead of npar and p- and p+...
...found a place where it doesn't work properly though
;;; Hatch between two polylines.
;;;
;;; Gian Paolo Cattaneo - 14.09.2013
;;;
;;; Marko Ribar modified - 15.09.2013
;;;
;;; Gian Paolo Cattaneo - 16.09.2013
;;; Fixed a bug for polylines drawn from right to left.
;;;
;;;
(defun c:TesT (/ *error* cmd e3 e3_ e3p
e3p_ n_par p_vert ListaV ListaVp LPint
contorno_trat p+ p- adoc
inv_p1 inv_p2
)
(vl-load-com)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(defun *error* (msg)
(if adoc
(vla-endundomark adoc)
)
(if cmd
(setvar 'cmdecho cmd)
)
(if msg
(prompt msg)
)
(princ)
)
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(vla-startundomark adoc)
(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)))
(progn
(setq ListaV (reverse ListaV))
(setq inv_p1 t)
)
)
;;; 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)))
(progn
(setq ListaVp (reverse ListaVp))
(setq inv_p2 t)
)
)
(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 ")
(*error* nil)
(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+ L dist )
;First polyline
(setq Dp- (vlax-curve-getDistAtPoint e3 p-))
(setq Dp+ (vlax-curve-getDistAtPoint e3 p+))
(if inv_p1
(setq
L (vlax-get-property (vlax-ename->vla-object e3) 'length)
Dp- (- L Dp-)
Dp+ (- L Dp+)
)
)
(mapcar
'(lambda (x)
(setq dist (vlax-curve-getDistAtPoint e3 x))
(if inv_p1 (setq dist (- L dist)))
(if (and
(> dist 1e-6)
(> dist Dp-)
(< dist 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+))
(if inv_p2
(setq
L (vlax-get-property (vlax-ename->vla-object e3p) 'length)
Dp- (- L Dp-)
Dp+ (- L Dp+)
)
)
(mapcar
'(lambda (x)
(setq dist (vlax-curve-getDistAtPoint e3p x))
(if inv_p2 (setq dist (- L dist)))
(if (and
(> dist 1e-6)
(> dist Dp-)
(< dist 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))))
)
)
;;;ListClockwise-p
(defun ListClockwise-p (lst / z vlst)
(vl-catch-all-apply
'minusp
(list
(if
(not
(equal 0.0
(setq z
(apply '+
(mapcar
(function
(lambda (u v)
(- (* (car u) (cadr v))
(* (car v) (cadr u))
)
)
)
(setq vlst
(mapcar
(function
(lambda (a b)
(mapcar '- b a)
)
)
lst
(cdr (reverse
(cons (car lst)
(reverse lst)
)
)
)
)
)
(cdr (reverse (cons (car vlst)
(reverse vlst)
)
)
)
)
)
)
1e-6
)
)
z
(progn
(prompt
"\n\nChecked vectors are colinear - unable to determine clockwise-p of list"
)
nil
)
)
)
)
)
;;;Return the hatch color
(defun calcolo_tipo_area nil
(if (ListClockwise-p contorno_trat)
(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")
)
...
(setq vlst
(mapcar
(function
(lambda (a b)
(mapcar '- b a)
)
)
lst
(cdr (reverse
(cons (car lst)
(reverse lst)
)
)
)
)
)
...
...
(setq vlst
(mapcar
(function
(lambda (a b)
(mapcar '- b a)
)
)
(mapcar
(function
(lambda (x)
(car lst)
)
) lst
)
(cdr (reverse
(cons (car lst)
(reverse lst)
)
)
)
)
)
...
A color number or standard color name is required.any suggestion
Error: bad argument value: AcDbCurve 71
New background color [Truecolor/COlorbook/. (for none)] <None>: *Cancel*
Code - Auto/Visual Lisp: [Select]
;; ; ;; mk_lwp by Alan J Thompson (Modified by ymg for closed poly) ; ;; ; ;; Argument: pl, A list of points (2d or 3d) ; ;; Create an LWPolyline at Elevation 0, on Current Layer. ; ;; Return: Polyline Object ; ;; ; ) '(100 . "AcDbEntity") '(100 . "AcDbPolyline") ) ) ) ) )
I believe there is a typo in your code at line 15,
also as submitted will not work for list of 2d point.
I believe there is a typo in your code at line 15,
also as submitted will not work for list of 2d point.
There is no typo as far as I can see; trans will always return a 3D point.
Note that your modifications will cause the function to fail for a UCS whose origin elevation is not equal to that of the WCS origin.
Select Reference Polyline:any reason for that
Select objects:
Select Proposed Polyline:
Select objects:
2D point or option keyword required.
2D point or option keyword required.
2D point or option keyword required.
2D point or option keyword required.
2D point or option keyword required.
2D point or option keyword required.
Error: bad argument type: lentityp nil
Specify internal point or [Properties/Select objects/draW boundary/remove Boundaries/Advanced/DRaw order/Origin/ANnotative/hatch COlor/LAyer/Transparency]:
(vl-cmdf "._-HATCH" "_CO" hcol "_P" "SOLID" "_S" bnd "" "")