LISP TO SELECT BOUNDARY/POLYLINE/POLYGON FROM TEXT INSIDE IT

[Sandeep RC]

PLEASE FIND THE ATTCHED CAD FILE, I HAVE COPIED RELEATIVELY SMALL AREA, IS THERE ANY LISP TO SELECT BOUNDARY/POLYLINE/POLYGON BY SELECTING TEXT INSIDE IT?

OR CAN WE HATCH INSIDE THAT BOUNDARY BY SELECTING THAT TEXT?

PLEASE OPEN CAD FILE, FOR EXAMPLE IF I SELET 29, 93, 35 TEXT BY CLICKING ON IT, LISP SHOUD SELECT BOUNDARY AROUND IT OR HATCH INSIDE IT?  SO THAT I CAN COPY THOSE IN A SEPERATE CAD FILE.

EXPERT GUYS PLEASE HELP FINDING ME ROUTINE FOR THIS.

Drawing1.dwg

Edited March 7, 2022 by Sandeep RC

[Emmanuel Delay]

Not doubt cot completely what you want, but it's probably part of the solution.

 

Command BFTI

- Then the user selects all (polylines + text objects)

- Then in a while loop you click on the textelements.  

-> This will select and grip the polyline around the the text

 

How?  I draw a horizontal XLine through the text.  Then I look for intersect points with all the closed polylines.

If one of the  intersect points is to the left, and one to the right of the text, then the text is probably surrounded by that polyline.

 

Notice, for weird shapes of polylines this might not work 

 

 

(vl-load-com)

(defun drawxLine (pt vec)
 (entmakex (list (cons 0 "XLINE")
                 (cons 100 "AcDbEntity")
                 (cons 100 "AcDbXline")
                 (cons 10 pt)
                 (cons 11 vec))))
				 


;; Intersections  -  Lee Mac
;; http://www.lee-mac.com/intersectionfunctions.html
;; Returns a list of all points of intersection between two objects
;; for the given intersection mode.
;; ob1,ob2 - [vla] VLA-Objects
;;     mod - [int] acextendoption enum of intersectwith method
        ;; acextendnone 	      Do not extend either object
        ;; acextendthisentity 	Extend obj1 to meet obj2
        ;; acextendotherentity 	Extend obj2 to meet obj1
        ;; acextendboth 	      Extend both objects
(defun LM:intersections ( ob1 ob2 mod / lst rtn )
    (if (and (vlax-method-applicable-p ob1 'intersectwith)
             (vlax-method-applicable-p ob2 'intersectwith)
             (setq lst (vlax-invoke ob1 'intersectwith ob2 mod))
        )
        (repeat (/ (length lst) 3)
            (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn)
                  lst (cdddr lst)
            )
        )
    )
    (reverse rtn)
)
				 

;; BOUNDARY FROM TEXT INSIDE IT				 
(defun c:bfti ( / txt pt sel plines i xl intp dif1 dif2 pickset1)
  (princ "\nSelect all objects (polylines and text objects: ")
  (setq plines (ssget (list (cons 0 "POLYLINE,LWPOLYLINE"))))
  
  (while (setq sel (entsel "\nSelect Text object: "))
    (setq txt (car sel))
	(setq pt (cdr (assoc 10 (entget txt))))
	;; draw a horizontal xline
    (setq xl (drawxLine pt (list 1.0 0.0) ))
	;; find intersect points, such that the x-value of the text is between 
	
	(setq i 0)
    (repeat (sslength plines)
      (setq ent (ssname plines i))
	  
	  (setq intp (LM:intersections  (vlax-ename->vla-object xl) (vlax-ename->vla-object ent) acextendnone))
	  (if (= 2 (length intp)) (progn
	    (setq dif1 
		  (- (nth 0 pt) (nth 0 (nth 0 intp)))
		)
	    (setq dif2 
		  (- (nth 0 pt) (nth 0 (nth 1 intp)))
		)
		
		;; now see if one (of dif1 / dif 2) is positive, and one negative
		(if (or 
		  (and (< 0.0 dif1) (> 0.0 dif2) )
		  (and (< 0.0 dif2) (> 0.0 dif1) )
		  )
		  (progn
		    ;; select and grip the polyline
		    (sssetfirst nil (ssadd ent))

		  )
		)
	  ))
      (setq i (+ i 1))
    )
	;; delete the XLine
	(entdel xl)	
  )
  (princ)
)

 

[Sandeep RC]

thanks for reply, but this was not exactly i was looking for, can it create a hatch within boundary after selecting texts? above code some how does the partial work of selecting single boundary. but it is not working with multiple selections. can you please help regarding this?

 

Edited March 8, 2022 by Sandeep RC

[mhupp]

Might be backwards way of doing this but.

Will asks for you to select a text then will build a selections set of the "chak boundary" polylines that are on screen.

steps thought each polyline and selects everything inside of them and checks it against the original text.

if its a match that polyline will get added to ss1.

that poyline or multiple polylines will be selected at the end of the lisp.

 

Will display "Boundary Not Found"

if text isn't fully inside the boundary

or their isn't a boundary around the text like #32 all its walls are made up of other closed polylines.

 

(defun C:foo (/ txt ScrPts ss ss1 ent pts sscheck)
  (setq txt (car (entsel  "\nSelect Text"))
        ScrPts (GetScreenCoords)
        ss1 (ssadd)
  )
  (if (setq SS (ssget "_CP" ScrPts '((0 . "*POLYLINE") (8 . "CHAK BOUNDARY")  (410 . "Model"))))
    (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
      (setq pts (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent))))
      (if (setq sscheck (ssget "_WP" pts))
        (if (ssmemb txt sscheck)
          (ssadd ent SS1)
        )
      )
    )
  )
  (if (> (sslength ss1) 0)
    (sssetfirst nil ss1)
    (prompt "\nBoundary Not Found")
  )
  (princ)
)      
;Calculates View Window
(defun GetScreenCoords (/ ViwCen ViwDim ViwSiz VptMin VptMax)
  (setq ViwSiz (/ (getvar "VIEWSIZE") 2)
        ViwCen (getvar "VIEWCTR")
        ViwDim (list (* ViwSiz (apply '/ (getvar "SCREENSIZE"))) ViwSiz)
        VptMin (mapcar '- ViwCen ViwDim)
        VptMax (mapcar '+ ViwCen ViwDim)
  )
  (list VptMin VptMax)
)

 

 

[Sandeep RC]

TEXTS WHICH ARE ENCLOSED FULLY IN CLOSED POLYGON FOR THEM ALSO IT SAYS BOUNDARY NOT FOUND.

EVEN IF IT DOESNT SELECT THE BOUNDARY ITS OKAY FOR ME? CAN A ROUTINE /LISP MAKE A HATCH INSIDE SELECTED TEXT BOUNDARY? IF THIS HAPPENS, THEN ALSO HALF OF MY TIME WILL BE SAVED, REST I WILL DO IT MANUALLY,

 

[Sandeep RC]

LISP SHOULD EITHER HATCH OR SELECT THE BOUNDARY (MULTIPLE OFCOURSE) AFTER CLICKING ON THE TEXTS.

[Ish]

You can use hatch command pick point option. If you have already close boundary pline.

[Emmanuel Delay]

Does anyone know of a LISP way of making a hatch?

 

If so, I'll try to integrate it in this post.

 

Preferably something that takes parameters, something like

 

(defun drawHatch ( points pattern scale / ...)  ;; points of the boundaries, or perhaps a closed polyline object

)

 

[exceed]

2 minutes ago, Emmanuel Delay said:

Does anyone know of a LISP way of making a hatch?

 

If so, I'll try to integrate it in this post.

 

Preferably something that takes parameters, something like

 

(defun drawHatch ( points pattern scale / ...)  ;; points of the boundaries, or perhaps a closed polyline object

)

 

 

 

http://www.theswamp.org/index.php?topic=4814.msg194181#msg194181

LINK : ENTMAKE HATCH 

 

THIS WILL HELP YOU

 

[Emmanuel Delay]

@ exceed : Perfect.  Thank you.

 

Try this.

same procedure.

 

(vl-load-com)

(defun drawxLine (pt vec)
 (entmakex (list (cons 0 "XLINE")
                 (cons 100 "AcDbEntity")
                 (cons 100 "AcDbXline")
                 (cons 10 pt)
                 (cons 11 vec))))
				 


;; Intersections  -  Lee Mac
;; http://www.lee-mac.com/intersectionfunctions.html
;; Returns a list of all points of intersection between two objects
;; for the given intersection mode.
;; ob1,ob2 - [vla] VLA-Objects
;;     mod - [int] acextendoption enum of intersectwith method
        ;; acextendnone 	      Do not extend either object
        ;; acextendthisentity 	Extend obj1 to meet obj2
        ;; acextendotherentity 	Extend obj2 to meet obj1
        ;; acextendboth 	      Extend both objects
(defun LM:intersections ( ob1 ob2 mod / lst rtn )
    (if (and (vlax-method-applicable-p ob1 'intersectwith)
             (vlax-method-applicable-p ob2 'intersectwith)
             (setq lst (vlax-invoke ob1 'intersectwith ob2 mod))
        )
        (repeat (/ (length lst) 3)
            (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn)
                  lst (cdddr lst)
            )
        )
    )
    (reverse rtn)
)
				 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; http://www.theswamp.org/index.php?topic=4814.msg194181#msg194181
(defun entmakex-hatch (L a n s)
 ;; By ElpanovEvgeniy
 ;; L - list point
 ;; A - angle hatch
 ;; N - name pattern
 ;; S - scale

 ;; returne - hatch ename
 (entmakex
  (apply
   'append
   (list
    (list '(0 . "HATCH")
          '(100 . "AcDbEntity")
          '(410 . "Model")
          '(100 . "AcDbHatch")
          '(10 0.0 0.0 0.0)
          '(210 0.0 0.0 1.0)
          '(2 . "ANSI31")
          (if (= n "SOLID")
           '(70 . 1)
           '(70 . 0)
          ) ;_  if
          '(71 . 0)
          (cons 91 (length l))
    ) ;_  list
    (apply 'append
           (mapcar '(lambda (a)
                     (apply 'append
                            (list (list '(92 . 7) '(72 . 0) '(73 . 1) (cons 93 (length a)))
                                  (mapcar '(lambda (b) (cons 10 b)) a)
                                  '((97 . 0))
                            ) ;_  list
                     ) ;_  apply
                    ) ;_  lambda
                   l
           ) ;_  mapcar
    ) ;_  apply
    (list '(75 . 0)
          '(76 . 1)
          (cons 52 a)
          (cons 41 s)
          '(77 . 0)
          '(78 . 1)
          (cons 53 a)
          '(43 . 0.)
          '(44 . 0.)
          '(45 . 1.)
          '(46 . 1.)
          '(79 . 0)
          '(47 . 1.)
          '(98 . 2)
          '(10 0. 0. 0.0)
          '(10 0. 0. 0.0)
          '(451 . 0)
          '(460 . 0.0)
          '(461 . 0.0)
          '(452 . 1)
          '(462 . 1.0)
          '(453 . 2)
          '(463 . 0.0)
          '(463 . 1.0)
          '(470 . "LINEAR")
    ) ;_  list
   ) ;_  list
  ) ;_  apply
 ) ;_  entmakex
) ;_  defun

(defun getPolylineVertexes ( pline / lst i res)				   
  (setq lst (vlax-get (vlax-ename->vla-object pline) 'coordinates))
  (setq i 0)
  (setq res (list))
  (repeat (/ (length lst) 2)
    (setq res (append res (list
	  (list (nth i lst) (nth (+ i 1) lst) )
	)))
    (setq i (+ i 2))
  )
  res
)

  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
				 
				 
;; BOUNDARY FROM TEXT INSIDE IT				 
(defun c:bfti ( / txt pt sel plines i xl intp dif1 dif2 pickset1 lst lst2)
  (princ "\nSelect all objects (polylines and text objects: ")
  (setq plines (ssget (list (cons 0 "POLYLINE,LWPOLYLINE"))))
  
  (while (setq sel (entsel "\nSelect Text object: "))
    (setq txt (car sel))
	(setq pt (cdr (assoc 10 (entget txt))))
	;; draw a horizontal xline
    (setq xl (drawxLine pt (list 1.0 0.0) ))
	;; find intersect points, such that the x-value of the text is between 
	
	(setq i 0)
    (repeat (sslength plines)
      (setq ent (ssname plines i))
	  
	  (setq intp (LM:intersections  (vlax-ename->vla-object xl) (vlax-ename->vla-object ent) acextendnone))
	  (if (= 2 (length intp)) (progn
	    (setq dif1 
		  (- (nth 0 pt) (nth 0 (nth 0 intp)))
		)
	    (setq dif2 
		  (- (nth 0 pt) (nth 0 (nth 1 intp)))
		)
		
		;; now see if one (of dif1 / dif 2) is positive, and one negative
		(if (or 
		  (and (< 0.0 dif1) (> 0.0 dif2) )
		  (and (< 0.0 dif2) (> 0.0 dif1) )
		  )
		  (progn
		    ;; select and grip the polyline
		    (sssetfirst nil (ssadd ent))
			(setq lst (vlax-get (vlax-ename->vla-object ent) 'coordinates))
			(princ lst)
			(princ "\n")
			(setq lst2 (getPolylineVertexes  ent))
			(princ lst2)
			
			;; draw the hatch.
			;; Feel free to adapt these settings
			(entmakex-hatch
				(list lst2) ;; pointlist
				0.0 		;; angle
				"ANSI31" 	;; pattern
				1.0			;; hatch scale
			)
			

		  )
		)
	  ))
      (setq i (+ i 1))
    )
	;; delete the XLine
	(entdel xl)	
  )
  (princ)
)

 

[Steven P]

2 hours ago, Emmanuel Delay said:

Does anyone know of a LISP way of making a hatch?

 

If so, I'll try to integrate it in this post.

 

Preferably something that takes parameters, something like

 

(defun drawHatch ( points pattern scale / ...)  ;; points of the boundaries, or perhaps a closed polyline object

)

 

 

And of course you can do it with "command". I found that doing it that way you need to create or select a boundary polyline, circle or whatever and hatch that.

 

Solid hatching is slightly different to other styles so there is an 'if' command there. You can edit the hatch afterwards to change its settings as below. entname is the boundary.

 

It's been a while since i made that up but i think I did it that way so that the entname can be a polyline or a circle - don't think entmake let me do both easily, the polyline created before the hatch command as necessary. If you want to make the hatch using just points you'd have to create a polyline border, hatch that, then delete it. I might be wrong of course. 

 

    (if (= "SOLID" HatchStyle)
      (command "-bhatch" "p" "solid" "s" entname "" "")
      (command "-bhatch" "p" HatchStyle HatchScale HatchAngle "s" entname "" "")
    )
    (setq hatchentname (cdr (car (entget(entlast)))))
    (command "-hatchedit" hatchentname "CO" HatchColour) ;colour setting

 

A bit slower perhaps programmatically but works for me.

[Sandeep RC]

@ Emmanuel Delay, okay great

this is working good, but the only problem is there are around 12,000 texts which i have kept on different layers according to my needs and they are around 2000 to 3000 per batch, so i just cannot click on all those texts, can you please add multiple texts selection option? that will do my job and close the topic. thank you in advance.

Edited March 8, 2022 by Sandeep RC

[Emmanuel Delay]

Sure, that should work.

Give me some time, I'll see what I can do tomorrow

[Sandeep RC]

sure, im waiting

[BIGAL]

I dont know why no suggestion like this,  Pick a text and use bpoly, then  remember entlast and use it with hatch then erase bpoly so simple a lisp.

 

Can do all in one go you need to describe what is next step like how each hatch will be different in each boundary.

 

A side comment this has been answered numerous times with answers like, random color or from a list of hatches or changing hatch angle per boundary and so on.

 

[mhupp]

10 hours ago, BIGAL said:

I dont know why no suggestion like this,  Pick a text and use bpoly, then  remember entlast and use it with hatch then erase bpoly so simple a lisp.

 

Yes sometimes I over-complicate things because that's the first thing that pops into my head. ALSO user only giving us s vague process of what they want to do in the first post then changing/adding what they want to do.
 

(defun C:foo (/ PT A)
  (setq PT (cdr (entsel  "\nSelect Text")))
  (command "_.-Boundary" PT "")   
  (command "-Hatch" "S" (setq A (entlast)) "" "")
  (entdel A)
  (princ)
) 

 

--edit--

I mean really you don't even need to select the text just a point inside the plot with a getpoint. That would be two lines of code then.

(defun C:foo (/ PT A)
  (setq PT (getpoint  "\nSelect Plot to Hatch")))
  (command "-Hatch" PT "")
  (princ)
) 

 

Edited March 9, 2022 by mhupp

[Tharwat]

Here is my attempt in this regard.  

You can change hatch pattern "ANSI37" to suit yours.

 

(defun c:Test ( / *error* lws int sel ent lst doc cmd zom inc fnd prm ssn pos pts)
  ;; Tharwat Al Choufi - 9.Mar.2022	;;
  (defun *error* (m_)
    (and doc zom (vla-zoomprevious doc))
    (and cmd (setvar 'CMDECHO cmd))
    (and m_ (princ "\n*Cancel*"))
    (princ)
    )
  (and (princ "\nSelect single texts to hatch the boundary they reside in : ")
       (or (setq lws (ssget "_X" (list '(0 . "LWPOLYLINE") '(-4 . "<AND") '(-4 . "&=") '(70 . 1) '(-4 . "AND>") (cons 410 (getvar 'CTAB)))))
           (alert "No closed Polylines / Boundaries found in this drawing <!>")
           )
       (setq int -1 sel (ssget '((0 . "TEXT"))))
       (while (setq int (1+ int) ent (ssname sel int))
         (setq lst (cons ent lst))
         )
       (setq doc (vlax-get-acad-object) cmd (getvar 'CMDECHO) zom (or (vla-zoomextents doc) t))
       (setq int -1)
       (setvar 'CMDECHO 0)
       (while (and lst (setq int (1+ int) ent (ssname lws int)))
         (foreach itm (entget ent)
           (and (= (car itm) 10) (or (vl-position (setq prm (cdr itm)) pts) (setq pts (cons prm pts))))
           )
         (and (setq inc -1 pos nil fnd (ssget "_WP" pts '((0 . "TEXT"))))
              (while (and (not pos) (setq inc (1+ inc) ssn (ssname fnd inc)))
                (and (setq pos (vl-position ssn lst))
                     (progn
                       (setq lst (vl-remove ssn lst))
                       (vl-cmdf "_.-hatch" "_S" (ssadd ent) "" "_P" "ANSI37" "1.0" "" "")
                       )
                     )
                )
              )
         (setq pts nil)
         )
       )
  (*error* nil)
  (princ)
  ) (vl-load-com)
       

 

[Sandeep RC]

@ Tharwat

YOU ARE AWESOME...! 

[Tharwat]

6 hours ago, Sandeep RC said:

@ Tharwat

YOU ARE AWESOME...! 

You're welcome. 

[BIGAL]

Either of these  versions will hatch this if its 2 plines.

 

 

For Sandeep RC if your confident that all the areas are closed in some way either version will work, I exploded the plines so it was all lines and worked fine.

 

; hatch boundary's 
; By AlanH Mar 2022

(defun c:lothatch1 ( / ss x ang ent pt)

(setq ss (ssget (list (cons 0 "*TEXT"))))

(setq  ang 0.0)
(setvar 'HPSCALE 5.0)
(setvar 'hpname "Ansi31")

(repeat (setq x (sslength ss))
  (setq pt (cdr (assoc 10 (entget (ssname ss (setq x (1- x)))))))
  (command "bpoly" pt "")
  (setq ent (entlast))
  (setvar 'hpang ang)
  (command "-hatch" "S" ent "" "")
  (setq ang (+ ang 0.25))
  (entdel ent)
)

(princ)
)

(defun c:lothatch2 ( / ss x ang ent pt)

(setq ss (ssget (list (cons 0 "*TEXT"))))

(setq  ang 0.0)
(setvar 'HPSCALE 5.0)
(setvar 'hpname "Ansi31")

(repeat (setq x (sslength ss))
  (setq pt (cdr (assoc 10 (entget (ssname ss (setq x (1- x)))))))
  (setvar 'hpang ang)
  (command "-hatch" pt "" "")
  (setq ang (+ ang 0.25)) ; radians

)

(princ)
)