hatch2group

[martinle]

Hello,

 

I have taken the following code lines from the formum and tried something to change.

My problem is that it does not always work.

Unfortunately, I can not see the reason why it often works and often not.

 

This Lisp should:

 

There are many groups of objects in the drawing.

The drawing already contains some default hatching.

 

1) The user selects an existing hatching and then fills different areas belonging to different groups

With this hatching.

2) When the user has finished the "_ADDSELECTED" command, the Lisp should add each individual hatch to the group that they have

encloses.

 

It works often but not always! Why?

Please help.

 

Martin

 

Lisp:

;;----------------------=={ Inside-p }==----------------------;;
;;                                                            ;;
;;  Predicate function to determine whether a point lies      ;;
;;  inside a supplied LWPolyline.                             ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac - www.lee-mac.com                         ;;
;;  Using some code by gile (as marked below), thanks gile.   ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  pt  - 3D WCS point to test                                ;;
;;  ent - LWPolyline Entity against which to test point       ;;
;;------------------------------------------------------------;;
;;  Returns:  T if supplied point lies inside supplied LWPoly ;;
;;------------------------------------------------------------;;

(defun LM:Inside-p (pt ent / _GroupByNum lst nrm obj tmp)

 (defun _GroupByNum (l n / r)
   (if	l
     (cons
(reverse (repeat n
	   (setq r (cons (car l) r)
		 l (cdr l)
	   )
	   r
	 )
)
(_GroupByNum l n)
     )
   )
 )

 (if (= (type ent) 'VLA-OBJECT)
   (setq obj ent
  ent (vlax-vla-object->ename ent)
   )
   (setq obj (vlax-ename->vla-object ent))
 )

 (setq	lst
 (_GroupByNum
   (vlax-invoke
     (setq tmp
	    (vlax-ename->vla-object
	      (entmakex
		(list
		  (cons 0 "RAY")
		  (cons 100 "AcDbEntity")
		  (cons 100 "AcDbRay")
		  (cons 10 pt)
		  (cons 11 (trans '(1. 0. 0.) ent 0))
		)
	      )
	    )
     )
     'IntersectWith
     obj
     acextendnone
   )
   3
 )
 )
 (vla-delete tmp)
 (setq nrm (cdr (assoc 210 (entget ent))))

 ;; gile:
 (and
   lst
   (not (vlax-curve-getparamatpoint ent pt))
   (=
     1
     (rem
(length
  (vl-remove-if
    (function
      (lambda (p / pa p- p+ p0 s1 s2)
	(setq pa (vlax-curve-getparamatpoint ent p))
	(or
	  (and (equal (fix (+ pa
			      (if (minusp pa)
				-0.5
				0.5
			      )
			   )
		      )
		      pa
		      1e-8
	       )
	       (setq p-
		      (cond
			((setq p- (vlax-curve-getPointatParam
				    ent
				    (- pa 1e-
				  )
			 )
			 (trans p- 0 nrm)
			)
			((trans	(vlax-curve-getPointatParam
				  ent
				  (- (vlax-curve-getEndParam ent) 1e-
				)
				0
				nrm
			 )
			)
		      )
	       )
	       (setq p+
		      (cond
			((setq p+ (vlax-curve-getPointatParam
				    ent
				    (+ pa 1e-
				  )
			 )
			 (trans p+ 0 nrm)
			)
			((trans	(vlax-curve-getPointatParam
				  ent
				  (+ (vlax-curve-getStartParam ent) 1e-
				)
				0
				nrm
			 )
			)
		      )
	       )
	       (setq p0 (trans pt 0 nrm))
	       (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+))))
	       ;; LM Mod
	  )
	  (and
	    (/= 0. (vla-getBulge obj (fix pa)))
	    (equal
	      '(0. 0.)
	      (cdr
		(trans (vlax-curve-getFirstDeriv ent pa) 0 nrm)
	      )
	      1e-9
	    )
	  )
	)
      )
    )
    lst
  )
)
2
     )
   )
 )
)
(defun c:hatch2group (/ ss i lst pt ent drehwink pt1 as OBJ AWS mypick)
 (setq mypick (getvar "pickstyle"))
 (setvar "pickstyle" 0)
 (setq OBJ (entlast))
 (command "_ADDSELECTED"
   Pause
   (setq pt1 (getpoint "\nPick Point: "))
 )
 (while (/= (getvar "CMDACTIVE") 0) (command pause))
 (setq AWS (ssadd))
 (while (setq OBJ (entnext OBJ)) (ssadd OBJ AWS))
 (sssetfirst AWS AWS)
 (setq as (entlast))
 (if
   (and (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
 (repeat (setq i (sslength ss))
   (setq lst (cons (ssname ss (setq i (1- i))) lst))
 )
 (setq pt pt1)
   )
    ;(if
      (setq ent
      (car
	(vl-member-if
	  (function
	    (lambda (x) (LM:Inside-p (trans pt 1 0) x))
	  )
	  lst
	)
      )
      )
;(vla-put-color (vlax-ename->vla-object ent) acRed)
    
 )
 (princ)
 (command "_groupedit" ent "H" AWS "")
 (while (/= (getvar "CMDACTIVE") 0) (command pause))
 (setvar "pickstyle" mypick)
 (princ)
)
(princ)