selection of blocks that have their point of origin in a polygon, avoiding other blocks with the same name but that still overlap a little in the polygon

[Manuelmfec]

Colleagues, best regards. Today I come to ask for help. I have developed a routine that splits a polygon based on the location of the origin of the blocks above it; However, the selection takes into account other blocks that overlap only slightly in the polygon, allowing me to run the routine anyway but with an undesired result.
I can remove the blocks manually, but when there are too many it becomes very tedious and time-consuming. I want to know if there is a way to avoid these external blocks that alter the results of my routine.
In the attached dwg I present 2 cases, in the one on the right the routine works without problems, however in the one on the left the complication occurs with the blocks external to the polygon but that still overlap a little.
Another complication that arises is when the polygon presents an arc.

Attached dwg and lisp file

I am very grateful for the help and attention provided.

ORIGENpl.lsp SEGMENTACION.dwg

[mhupp]

Why it doesn't work with arcs

https://www.cadtutor.net/forum/topic/76326-selection-set-that-selects-objects-inside-a-curved-polyline/?do=findComment&comment=603264

[BIGAL]

You should be able to get all the blocks using say SSGET "F" then check is the insertion point on the object. use maybe getclosestpointto it should reveal 0.0 for insert on pline use a (equal dist 0.0 1E-08) this looks for up to 0.000000001 offset. Sometimes its just not 0.0. 

 

Part 2 is break the arc down into little straights, so the "F" option works. Code is out there. 

Edited December 4, 2023 by BIGAL

[Steven P]

See the link from MHUPP, or below, I needed the same a week or so ago so made this one:

 

Poly2Chords will adjust the polyline to 'arcs' with straight sections, the Poly2Chords_List will return just the list of points and can be used in ssget with 'F' filter

 

(needs a small change, Poly2Chords won't take acount of an arc with variable width)

 

(defun c:Poly2Chords ( / MyEnt MyChords ModifiedEnt)
;;Select Entity
  (setq MyEnt (entget (car (entsel))))     ; Select Polyline / Line Entity 
  (setq MyChords (getreal "Chords in 360 degrees: "))
  (setq ModifiedEnt (PolyChords MyEnt MyChords)) ; Returns modified entity definition list
  (entmod ModifiedEnt)                    ; Here create a new polyline, can also (entmod...) instead
  (princ)
)
(defun c:Poly2Chords_List ( / MyEnt MyChords ModifiedEnt)
  (defun mAssoc ( key lst / result ) ;;Lee Mac: https://www.cadtutor.net/forum/topic/27914-massoc-implementations/
   (foreach x lst
     (if (= key (car x))
       (setq result (cons (cdr x) result))
     )
   )
  (setq MyEnt (entget (car (entsel))))     ; Select Polyline / Line Entity 
  (setq MyChords (getreal "Chords in 360 degrees: "))
  (setq ModifiedEnt (PolyChords MyEnt MyChords))
  (princ (mAssoc 10 ModifiedEnt))

)

(defun PolyChords ( MyEnt vertexin360 / vertexin360 NewEnt acount p1 p2 open Open b MyBulge MyBulgeC StartAng EndAng MyRadius ccw Chordangle Chords ChordCount NewPt)

(princ "OK ")

;;Add in start / end thickness 40, 41
;;Add in if arc selected do conversion

;;;;; Sub Functions
  (defun LM:Bulge->Arc ( p1 p2 b / c r ) ;; Refer to Lee Mac Website ;;Gives Arc definition from pline Bulge
    (setq r (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
          c (polar p1 (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b)))) r)
    )
    (if (minusp b)
        (list c (angle c p2) (angle c p1) (abs r))
        (list c (angle c p1) (angle c p2) (abs r))
    )
  )
  (defun LM:BulgeCenter ( p1 p2 b ) ;; Refer to Lee Mac Website ;;Gives Arc definition from pline Bulge
    (polar p1
        (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b))))
        (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
    )
  )
  (defun mAssoc ( key lst / result ) ;;Lee Mac: https://www.cadtutor.net/forum/topic/27914-massoc-implementations/
   (foreach x lst
     (if (= key (car x))
       (setq result (cons (cdr x) result))
     )
   )
   (reverse result)
  )
;;;;; End Sub Functions

;;Set Variables
;;  (setq vertexin360 180)               ; Number of chords in full circle, 360: every 1 degree
  (setq NewEnt (list))                 ; New List for the modified entity definition
  (setq acount 0)                      ; A counter

;;Find curves '42'
  (while (< acount (length MyEnt))
    (if  (and (=  (car (nth acount MyEnt)) 42) ; if dxf code 42
              (/= (cdr (nth acount MyEnt)) 0)  ; and is a value: a bulge!
         ) ; end and
      (progn
        (setq p1 (cdr (nth (- acount 3) MyEnt))) ; Start Coordinate
        (setq p2 (nth (+ acount 2) MyEnt))       ; End Coordinate as dxf code
          (if (= (car p2) 210)                   ; If P2 is "210" and not a "10" - end of polyline
          (if (= (cdr (assoc 70 MyEnt)) 1)
            (progn                               ; Closed Polyline
              (setq p2 (assoc 10 MyEnt))         ; Set end coordinate to start coordinate
              (setq open nil)
            ) ; end progn
            (progn                               ;Open PolyLine, end of polyline
              (setq Open "Open")
            ) ; end progn
          ) ; end if closed / open
        ) ; end if 210
        (setq p2 (cdr p2))                       ; End Coordinate
        (setq b (cdr (nth acount MyEnt)))        ; Bulge
        (if (= Open "Open")                      ; If next point is '210'
          ()                                     ; End of chords
          (progn                                 ; Calculate Chords
            (setq MyBulge (LM:Bulge->Arc p1 p2 b))    ; Bulge as arc
            (setq MyBulgeC (LM:BulgeCenter p1 p2 b) ) ; Bulge Centre
            (setq StartAng (nth 1 MyBulge))           ; start angle centre to point
            (setq EndAng   (nth 2 MyBulge))           ; End angle centre to point
            (setq MyRadius (nth 3 MyBulge))           ; Bulge radius
            (if (< 0 b)(setq ccw 1)(setq ccw -1))     ; clockwise / anticlockwise
            (setq Chordangle (/ (* 4 (atan b))) )
            (setq Chords (* ( /  Chordangle (/ (* 2 pi) vertexin360)) ccw) ) ; point every nth degree

;            (if (> Chords vertexin360) ;;Check number of chords isn't too big: TL, TR 'corners'. Not needed?
;              (progn
;                (setq Chordangle (+ (- (cadr MyBulge) (caddr MyBulge)) (* 1 pi)) )
;                (setq Chords (/  Chordangle (/ (* 2 pi) vertexin360) )) ; point every x degrees
;            )) ; end progn ; end if
            (setq ChordCount 1)

            (while (< ChordCount Chords)
              (if (= ccw 1)
                (setq NewPt (polar MyBulgeC (+ (* (/ (* 2 pi) vertexin360) ChordCount) StartAng) MyRadius) )
                (setq NewPt (polar MyBulgeC (- EndAng (* (/ (* 2 pi) vertexin360) ChordCount) ) MyRadius) )
              )
              (setq NewEnt (append NewEnt (list (cons 42 0)) ) )    ; bulge value: 0
              (setq NewEnt (append NewEnt (list (cons 91 0)) ) )    ; Vertex Identifier
              (setq NewEnt (append NewEnt (list (cons 10 NewPt)) )) ; Point
              (setq NewEnt (append NewEnt (list (cons 40 0)) ) )    ; Start width
              (setq NewEnt (append NewEnt (list (cons 41 0)) ) )    ; end width
              (setq ChordCount (+ ChordCount 1))
            ) ; end while
          ) ; end progn
        ) ; end if Open (end of line)
      ) ; end progn

      (progn
        (setq NewEnt (append NewEnt (list (nth acount MyEnt)) ) ) ; Add other DXF codes to NewEnt listing
      ) ; end progn
    ) ; end if '42'
    (setq acount (+ acount 1))
  ) ; end while length MyEnt

  (setq NewEnt (subst (cons 90 (length (mAssoc 10 NewEnt))) (assoc 90 NewEnt) NewEnt )) ; update number of verticies
;;add in 70 for continuos line types
  NewEnt ; return new entity definition
)

 

[XDSoft]

[XDrX-PlugIn(156)] Keep the blocks on the polyline and delete other blocks with. (theswamp.org)

 

https://www.theswamp.org/index.php?topic=59504.msg620549#msg620549

 

 

 

 

(defun c:xdtb_pl_tolerase (/ E typ blkname ss fence-box plane)
  (xd::doc:getdouble
    (xdrx-string-multilanguage
      "\n搜索范围"
      "\nSearch range tolerance"
    )
    "#xd-var-global-search-tol"
    (xd::doc:getpickboxheight)
  )
  (xd::doc:getdouble
    (xdrx-string-multilanguage
      "\n点线容差精度"
      "Point and line tolerance"
    )
    "#xd-var-global-tol-dist"
    (xdrx-getvar "equalpoint")
  )
  (if (and (setq e (car	(xdrx-entsel
			  (xdrx-string-multilanguage
			    "\n拾取特征图元类型<退出>:"
			    "\nPick feature entity type<Exit>:"
			  )
			)
		   )
	   )
	   (setq typ	 (assoc 0 (entget e))
		 blkname (xdrx-getpropertyvalue e "name")
	   )
	   (setq ss (xdrx-ssget
		      (xdrx-string-multilanguage
			"\n选择多段线<退出>:"
			"\nSelect Polyline<Exit>:"
		      )
		      '((0 . "*polyline"))
		    )
	   )
      )
    (progn
      (xdrx-begin)
      (mapcar
	'(lambda (x)
	   (if (and (setq fence-box (xdrx-getpropertyvalue
				      x
				      "tofence"
				      #xd-var-global-search-tol
				      1
				    )
		    )
		    (setq fence-box (xdrx-getsamplept fence-box))
		    (setq
		      ss1 (ssget "cp"
				 fence-box
				 (list typ)
			  )
		      ss2 (ssget "f" (xdrx-getsamplept x) (list typ))
		    )
	       )
	     (progn
	       (setq nums  0
		     plane (xdrx-getpropertyvalue x "plane" t)
	       )
	       (mapcar '(lambda	(y)
			  (setq	position (xdrx-getpropertyvalue
					   y
					   "position"
					 )
				closest	 (xdrx-getpropertyvalue
					   x
					   "getclosestpointto"
					   position
					 )
				position (xdrx-point-orthoproject position plane)
				closest	 (xdrx-point-orthoproject closest plane)
			  )
			  (if (not (equal closest position #xd-var-global-tol-dist))
			    (progn
			      (setq nums (1+ nums))
			      (xdrx-entity-delete y)
			    )
			  )
			)
		       (xdrx-ss->ents ss1)
	       )
	       (xdrx-prompt
		 (xdrx-string-formatex
		   (xdrx-string-multilanguage
		     "\n共删除了 %d 个容差范围内的不在多段线线上的图块."
		     "\nA total of %d tiles matching the feature criteria were deleted."
		   )
		   nums
		 )
	       )
	     )
	   )
	 )
	(xdrx-ss->ents ss)
      )
      (xdrx-end)
    )
  )
  (princ)
)

 

 

====================

 

The above code uses XDRX API, download link:

 

https://github.com/xdcad
https://sourceforge.net/projects/xdrx-api-zip/
http://bbs.xdcad.net