Highlight & count blocks not inside polylines

March 30, 2020

Hello everyone,
This is my first post in this forum.I have heard people here are very friendly and helpful.
I need help with you all lisp masters.So here is my case-
I have multiple closed polylines ,each polyline has a label (here labels are Zone A,Zone B,Zone C,Zone D for example purpose) which may be text or mtext entity.Note that the label name may be different but it will be always single label for each polyline.
Now there are mutliple blocks (dynamic in nature) inside,outside or overlapping (between zones) .Note that the blocks can be of any name
I want to highlight and count blocks which are not completely inside any polyline or overlapping between polylines.
So here is the example for better understanding (Please refer to below image)

After running program,we should get something like that in autocad command line
Total Found- 15 (include both outside and overlapping)
Not Inside any zones- 10 (Red highlighted one)
Overlapping between Zone A and Zone B- 3 (Blue highlighted one)
Overlapping between Zone B and Zone D- 2 (Blue highlighted one)

There may be cases were blocks may be not be overlapping between polylines ,so in such cases overlapping part should be omitted.
I don't know how tough is that to do in lisp, since I am completely novice in this department.

I am also attaching the sample dwg file for reference.

Thanks for consideration.
Have a good day!!

Zones_Cadtutor.dwg

March 30, 2020

Not exactly what you wanted, but it's good for a start...

(defun c:zonesblkschk ( / ss sslws ssblks i e pl txt zoneblks ii zoneblkslst zonesblkslst touchingblks touchingblkslst touchingzonesblkslst freeblks ssfree )
  (vl-cmdf "_.ZOOM" "_E")
  (vl-cmdf "_.ZOOM" "0.75XP")
  (prompt "\nSelect ZONES and BLOCKS for check...")
  (if (setq ss (ssget))
    (progn
      (setq sslws (ssadd) ssblks (ssadd))
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (cond
          ( (= (cdr (assoc 0 (entget e))) "LWPOLYLINE")
            (ssadd e sslws)
          )
          ( (= (cdr (assoc 0 (entget e))) "INSERT")
            (ssadd e ssblks)
          )
        )
      )
      (repeat (setq i (sslength sslws))
        (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget (ssname sslws (setq i (1- i)))))))
        (setq txt (cdr (assoc 1 (entget (ssname (ssget "_CP" pl '((0 . "*TEXT"))) 0)))))
        (setq zoneblks (ssget "_CP" pl '((0 . "INSERT"))))
        (repeat (setq ii (sslength zoneblks))
          (setq zoneblkslst (cons (ssname zoneblks (setq ii (1- ii))) zoneblkslst))
        )
        (setq zonesblkslst (append zonesblkslst zoneblkslst))
        (setq zoneblkslst nil)
        (setq touchingblks (ssget "_F" (if (not (equal (car pl) (last pl))) (append pl (list (car pl))) pl) '((0 . "INSERT"))))
        (if touchingblks
          (progn
            (repeat (setq ii (sslength touchingblks))
              (setq touchingblkslst (cons (ssname touchingblks (setq ii (1- ii))) touchingblkslst))
            )
            (setq touchingblkslst (list txt touchingblkslst))
            (setq touchingzonesblkslst (cons touchingblkslst touchingzonesblkslst))
            (setq touchingblkslst nil)
          )
        )
      )
      (foreach zone touchingzonesblkslst
        (prompt "\nOverlapping blocks of ZONE : ") (princ (car zone)) (prompt " -> : ") (princ (length (cadr zone))) (prompt " blocks...")
      )
      (repeat (setq i (sslength ssblks))
        (if (not (vl-position (ssname ssblks (setq i (1- i))) zonesblkslst))
          (setq freeblks (cons (ssname ssblks i) freeblks))
        )
      )
      (princ "\n")
      (prompt "\nFree blocks not inside any ZONE : ") (princ (length freeblks))
      (setq ssfree (ssadd))
      (foreach blk freeblks
        (ssadd blk ssfree)
      )
      (sssetfirst nil ssfree)
    )
  )
  (princ)
)

[EDIT : I had lack... Changed to : (setq touchingblks (ssget "_F" (if (not (equal (car pl) (last pl))) (append pl (list (car pl))) pl) '((0 . "INSERT"))))

Edited March 31, 2020 by marko_ribar

March 30, 2020

33 minutes ago, marko_ribar said:

Not exactly what you wanted, but it's good for a start...


(defun c:zonesblkschk ( / ss sslws ssblks i e pl txt zoneblks ii zoneblkslst zonesblkslst touchingblks touchingblkslst touchingzonesblkslst freeblks ssfree )
  (vl-cmdf "_.ZOOM" "_E")
  (vl-cmdf "_.ZOOM" "0.75XP")
  (prompt "\nSelect ZONES and BLOCKS for check...")
  (if (setq ss (ssget))
    (progn
      (setq sslws (ssadd) ssblks (ssadd))
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (cond
          ( (= (cdr (assoc 0 (entget e))) "LWPOLYLINE")
            (ssadd e sslws)
          )
          ( (= (cdr (assoc 0 (entget e))) "INSERT")
            (ssadd e ssblks)
          )
        )
      )
      (repeat (setq i (sslength sslws))
        (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget (ssname sslws (setq i (1- i)))))))
        (setq txt (cdr (assoc 1 (entget (ssname (ssget "_CP" pl '((0 . "*TEXT"))) 0)))))
        (setq zoneblks (ssget "_CP" pl '((0 . "INSERT"))))
        (repeat (setq ii (sslength zoneblks))
          (setq zoneblkslst (cons (ssname zoneblks (setq ii (1- ii))) zoneblkslst))
        )
        (setq zonesblkslst (append zonesblkslst zoneblkslst))
        (setq zoneblkslst nil)
        (setq touchingblks (ssget "_F" pl '((0 . "INSERT"))))
        (if touchingblks
          (progn
            (repeat (setq ii (sslength touchingblks))
              (setq touchingblkslst (cons (ssname touchingblks (setq ii (1- ii))) touchingblkslst))
            )
            (setq touchingblkslst (list txt touchingblkslst))
            (setq touchingzonesblkslst (cons touchingblkslst touchingzonesblkslst))
            (setq touchingblkslst nil)
          )
        )
      )
      (foreach zone touchingzonesblkslst
        (prompt "\nOverlapping blocks of ZONE : ") (princ (car zone)) (prompt " -> : ") (princ (length (cadr zone))) (prompt " blocks...")
      )
      (repeat (setq i (sslength ssblks))
        (if (not (vl-position (ssname ssblks (setq i (1- i))) zonesblkslst))
          (setq freeblks (cons (ssname ssblks i) freeblks))
        )
      )
      (princ "\n")
      (prompt "\nFree blocks not inside any ZONE : ") (princ (length freeblks))
      (setq ssfree (ssadd))
      (foreach blk freeblks
        (ssadd blk ssfree)
      )
      (sssetfirst nil ssfree)
    )
  )
  (princ)
)

Thanks @marko_ribar Sir ,for this amazing piece of lisp code.
I was just wondering if we can also highlight the overlapping blocks by some circles or any other shapes so that it is easily visible to user since there will be many such blocks in some cases ?
Once again thanks for your effort and time

March 30, 2020

Since I'm so bored due to quarantine, I've taken quite the time to do this one:

(defun c:notinside ( / *error* acadobj activeundo adoc ains alaps bb blk dets ent i ins j laprect laps maxpt minpt msg msp obname oneb orgblk pl plpt ss ssnotbl str vx x y zdet zname znames)

  ;; Error handling function
  (defun *error* ( msg )
    (if (eq (type x) 'ename)
      (progn
        (vla-Highlight (vlax-ename->vla-object x) :vlax-false)
        (vla-update acadobj)
        )
      )
    
    (vla-EndUndoMark adoc)
    (if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*"))
      (princ (strcat "Error: " msg))
      )
    )
  (setq acadobj (vlax-get-acad-object)
        adoc (vla-get-ActiveDocument acadobj)
        msp (vla-get-ModelSpace adoc)
        activeundo nil)
  (if (= 0 (logand 8 (getvar "UNDOCTL"))) (vla-StartUndoMark adoc) (setq activeundo T))

  ;; Start function

  (if (setq ss (ssget '((0 . "INSERT,*POLYLINE"))))
    (progn
      (repeat (setq i (sslength ss))
        (if (eq (cdr (assoc 0 (entget (setq ent (ssname ss (setq i (1- i))))))) "INSERT")
          (setq blk (cons ent blk))
          (setq pl (cons ent pl))
          )
        )
      
      (setq orgblk (length blk))
      (foreach x pl
        
        ;; Get zone name
        
        (vla-Highlight (setq vx (vlax-ename->vla-object x)) :vlax-true)
        (while
          (progn
            (initget 1 "Name")
            (setq zname (entsel "\nSelect text specifying zone name for highlighted line or [Name]: "))
            (cond
              ((null zname) (princ "\nNothing selected"))
              ((eq zname "Name")
               (setq zname (getstring T "\nSpecify name for highlighted line: "))
               (if (vl-position zname znames)
                 (progn (princ (strcat "\nName \"" zname "\" already exist. Please enter a new name")) T)
                 (progn (setq znames (cons zname znames)) nil)
                 )
               )
              ((not (wcmatch (cdr (assoc 0 (entget (car zname)))) "TEXT,MTEXT")) (princ "\nObject is not a text"))
              ((setq zname (cdr (assoc 1 (entget (car zname)))))
               (if (vl-position zname znames)
                 (progn (princ (strcat "\nName \"" zname "\" already exist. Please enter a new name")) T)
                 (progn (setq znames (cons zname znames)) nil)
                 )
               )
              )
            )
          )
        (vla-Highlight vx :vlax-false)
        (vla-update acadobj)
        
        ;; Get overlaps & Inside
        
        (vla-ZoomWindow acadobj
          (progn
            (vla-GetBoundingBox vx 'minpt 'maxpt)
            minpt
            )
          maxpt
          )
        (setq plpt (mapcar 'cdr (vl-remove-if-not '(lambda (y) (eq (car y) 10)) (entget x)))
              plpt (if (and (eq (cdr (assoc 70 (entget x))) 1) (null (equal (car plpt) (last plpt) 1))) (append plpt (list (car plpt))) plpt)
              laps (ssget "_F" plpt '((0 . "INSERT")))
              ins (ssget "_CP" plpt '((0 . "INSERT")))
              ains (cons ins ains)
              )

        (mapcar '(lambda (x y / bb)
                   (if (setq bb (ssget "_F" (list x y) '((0 . "INSERT"))))
                     (repeat (setq j (sslength bb))
                       (if (ssmemb (setq ent (ssname bb (setq j (1- j)))) ss)
                         (setq laprect (cons (apply 'JH:rectcorner (LM:ssboundingbox bb)) laprect))
                         )
                       )
                     )
                   )
                (reverse (cdr (reverse plpt)))
                (cdr plpt)
                )
        
        (vla-ZoomPrevious acadobj)
        
        (if laps
          (progn
            (repeat (setq i (sslength laps))
              (if (ssmemb (setq ent (ssname laps (setq i (1- i)))) ss)
                (setq alaps (cons (cons zname ent) alaps))
                )
              )
            
            )
          )
        
        (if ins
          (repeat (setq i (sslength ins))
            (setq blk (vl-remove (ssname ins (setq i (1- i))) blk))
            )
          )
        )
      
      ;; Get Details

      (setq ssnotbl (JH:list-to-selset blk))
      (while alaps
        (setq oneb (vl-remove-if-not '(lambda (x) (eq (cdr x) (cdar alaps))) alaps)
              dets (cons (cons (vla-get-EffectiveName (vlax-ename->vla-object (cdar alaps))) (LM:lst->str (vl-sort (mapcar 'car oneb) '(lambda (a b) (< a b))) ", ")) dets)
              alaps (vl-remove-if '(lambda (x) (eq (cdr x) (cdar alaps))) alaps)
              )
        )
      
      (setq obname (mapcar '(lambda (x) (vla-get-EffectiveName (vlax-ename->vla-object x))) blk)
            str (mapcar '(lambda (x)
                           (strcat "\n" (itoa (JH:CountSpecific zdet x)) " blocks overlapping on boundaries " x " ("
                                   (LM:lst->str (mapcar '(lambda (y) (strcat (itoa (cdr y)) " " (car y))) (LM:CountItems (mapcar 'car (vl-remove-if-not '(lambda (y) (eq x (cdr y))) dets)))) ", ")
                                   ")"
                                   )
                           )
                        (LM:Unique (setq zdet (mapcar 'cdr dets)))
                        )
            msg (strcat
                  "\nTotal number of blocks in selection: " (itoa orgblk)
                  "\nTotal number of zones identified: " (itoa (length pl)) " (" (cond ((LM:lst->str (vl-sort znames '(lambda (a b) (< a b))) ", ")) ("")) ")"
                  "\n"
                  "\nNumber of blocks outside zones: " (itoa (length blk)) " (" (cond ((LM:lst->str (mapcar '(lambda (x) (strcat (itoa (cdr x)) " " (car x))) (LM:CountItems obname)) ", ")) ("")) ")"
                  (apply 'strcat str)
                  "\n"
                  "\n"
                  "\nNumber of blocks outside and overlapping: " (itoa (+ (length blk)
                                                                          (length dets)
                                                                          )
                                                                       )
                  )
            )

      (entmake
        (list
          '(0 . "MTEXT")
          '(100 . "AcDbEntity")
          '(100 . "AcDbMText")
          (cons 1 msg)
          (cons 10 (progn (initget 1) (getpoint "\nSpecify insertion point for text: ")))
          '(40 . 2200)	; <--- Set text height here
          '(50 . 0)
          )
        )

      (foreach x (LM:UniqueFuzz laprect 1)
        (entmake
          (append
            '(
              (0 . "LWPOLYLINE")
              (100 . "AcDbEntity")
              (100 . "AcDbPolyline")
              (90 . 4)
              (70 . 1)
              (62 . 2)	; <--- Set color here. In this case, it's yellow. Depends on color index
              (43 . 300) ; <--- Set thickness here
              )
            (apply 'append
                   (mapcar '(lambda (y)
                              (list
                                (cons 10 y)
                                '(42 . 0)
                                '(91 . 0)
                                )
                              )
                           x
                           )
                   )
            )
          )
        )

      (sssetfirst nil ssnotbl)
      (princ msg)
      )
    )

  ;; End function
  
  (if activeundo nil (vla-EndUndoMark adoc))
  (princ)
  )

(defun JH:uniqueset (lst / fin)	; Returns a unique selection set from a list of selection sets
  (setq fin (ssadd))
  (mapcar '(lambda (x / a ent)
             (repeat (setq a (sslength x))
               (if (null (ssmemb (setq ent (ssname x (setq a (1- a)))) fin))
                 (setq fin (ssadd ent fin))
                 )
               )
             )
          lst
          )
  fin
  )

(defun JH:CountSpecific (lst itm)	; Returns the number of items itm is inside lst.
  (- (length lst)
     (length (vl-remove itm lst))
     )
  )


(defun JH:rectcorner (a b)
  (list
    a
    (list (car b) (cadr a) (last a))
    b
    (list (car a) (cadr b) (last a))
    )
  )

(defun JH:list-to-selset (lst / final)
  (setq final (ssadd))
  (mapcar '(lambda (x) (setq final (ssadd x final))) lst)
  final
  )

;; List to String  -  Lee Mac
;; Concatenates each string in a supplied list, separated by a given delimiter
;; lst - [lst] List of strings to concatenate
;; del - [str] Delimiter string to separate each item

(defun LM:lst->str ( lst del / str )
    (setq str (car lst))
    (foreach itm (cdr lst) (setq str (strcat str del itm)))
    str
)

;; Unique  -  Lee Mac
;; Returns a list with duplicate elements removed.

(defun LM:Unique ( l / x r )
    (while l
        (setq x (car l)
              l (vl-remove x (cdr l))
              r (cons x r)
        )
    )
    (reverse r)
)

;; Unique with Fuzz  -  Lee Mac
;; Returns a list with all elements considered duplicate to
;; a given tolerance removed.

(defun LM:UniqueFuzz ( l f / x r )
    (while l
        (setq x (car l)
              l (vl-remove-if (function (lambda ( y ) (equal x y f))) (cdr l))
              r (cons x r)
        )
    )
    (reverse r)
)

;; Count Items  -  Lee Mac
;; Returns a list of dotted pairs detailing the number of
;; occurrences of each item in a supplied list.

(defun LM:CountItems ( l / c l r x )
    (while l
        (setq x (car l)
              c (length l)
              l (vl-remove x (cdr l))
              r (cons (cons x (- c (length l))) r)
        )
    )
    (reverse r)
)

;; Selection Set Bounding Box  -  Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; sel - [sel] Selection set for which to return bounding box

(defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp )
    (repeat (setq idx (sslength sel))
        (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
        (if (and (vlax-method-applicable-p obj 'getboundingbox)
                 (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
            )
            (setq ls1 (cons (vlax-safearray->list llp) ls1)
                  ls2 (cons (vlax-safearray->list urp) ls2)
            )
        )
    )
    (if (and ls1 ls2)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
    )
)

Edited March 31, 2020 by Jonathan Handojo
Update to highlight outside blocks

March 30, 2020

Hi, my code is updated to highlight overlapping blocks. Hopefully it's of use.

March 30, 2020

Here's another .. no fancy reporting:

(defun c:foo (/ _s2l pts s)
  (defun _s2l (s)
    (if	s (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
  )
  (foreach x (_s2l (setq s (ssget '((0 . "insert,lwpolyline")))))
    (if	(= "LWPOLYLINE" (cdr (assoc 0 (entget x))))
      (progn (setq pts (mapcar 'cdr (vl-remove-if '(lambda (p) (/= 10 (car p))) (entget x))))
	     (foreach y (_s2l (ssget "_WP" pts '((0 . "insert")))) (ssdel y s))
	     (ssdel x s)
      )
    )
  )
  (sssetfirst nil s)
  (princ)
)

March 31, 2020

13 hours ago, Jonathan Handojo said:

Hi, my code is updated to highlight overlapping blocks. Hopefully it's of use.

Thanks @Jonathan Handojo sir for your awesome program. I am very thankful to you and hope this pandemic end soon .
The only thing I want is for block completely outside it should be highlighted like standard highlight in autocad ,no fancy .
See attached Image (red higlighted)

March 31, 2020

10 hours ago, ronjonp said:

Here's another .. no fancy reporting:


(defun c:foo (/ _s2l pts s)
  (defun _s2l (s)
    (if	s (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
  )
  (foreach x (_s2l (setq s (ssget '((0 . "insert,lwpolyline")))))
    (if	(= "LWPOLYLINE" (cdr (assoc 0 (entget x))))
      (progn (setq pts (mapcar 'cdr (vl-remove-if '(lambda (p) (/= 10 (car p))) (entget x))))
	     (foreach y (_s2l (ssget "_WP" pts '((0 . "insert")))) (ssdel y s))
	     (ssdel x s)
      )
    )
  )
  (sssetfirst nil s)
  (princ)
)

It is also good sir @ronjonp.
Thank you very much

March 31, 2020

15 hours ago, marko_ribar said:

Not exactly what you wanted, but it's good for a start...


(defun c:zonesblkschk ( / ss sslws ssblks i e pl txt zoneblks ii zoneblkslst zonesblkslst touchingblks touchingblkslst touchingzonesblkslst freeblks ssfree )
  (vl-cmdf "_.ZOOM" "_E")
  (vl-cmdf "_.ZOOM" "0.75XP")
  (prompt "\nSelect ZONES and BLOCKS for check...")
  (if (setq ss (ssget))
    (progn
      (setq sslws (ssadd) ssblks (ssadd))
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (cond
          ( (= (cdr (assoc 0 (entget e))) "LWPOLYLINE")
            (ssadd e sslws)
          )
          ( (= (cdr (assoc 0 (entget e))) "INSERT")
            (ssadd e ssblks)
          )
        )
      )
      (repeat (setq i (sslength sslws))
        (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget (ssname sslws (setq i (1- i)))))))
        (setq txt (cdr (assoc 1 (entget (ssname (ssget "_CP" pl '((0 . "*TEXT"))) 0)))))
        (setq zoneblks (ssget "_CP" pl '((0 . "INSERT"))))
        (repeat (setq ii (sslength zoneblks))
          (setq zoneblkslst (cons (ssname zoneblks (setq ii (1- ii))) zoneblkslst))
        )
        (setq zonesblkslst (append zonesblkslst zoneblkslst))
        (setq zoneblkslst nil)
        (setq touchingblks (ssget "_F" (append pl (list (car pl))) '((0 . "INSERT"))))
        (if touchingblks
          (progn
            (repeat (setq ii (sslength touchingblks))
              (setq touchingblkslst (cons (ssname touchingblks (setq ii (1- ii))) touchingblkslst))
            )
            (setq touchingblkslst (list txt touchingblkslst))
            (setq touchingzonesblkslst (cons touchingblkslst touchingzonesblkslst))
            (setq touchingblkslst nil)
          )
        )
      )
      (foreach zone touchingzonesblkslst
        (prompt "\nOverlapping blocks of ZONE : ") (princ (car zone)) (prompt " -> : ") (princ (length (cadr zone))) (prompt " blocks...")
      )
      (repeat (setq i (sslength ssblks))
        (if (not (vl-position (ssname ssblks (setq i (1- i))) zonesblkslst))
          (setq freeblks (cons (ssname ssblks i) freeblks))
        )
      )
      (princ "\n")
      (prompt "\nFree blocks not inside any ZONE : ") (princ (length freeblks))
      (setq ssfree (ssadd))
      (foreach blk freeblks
        (ssadd blk ssfree)
      )
      (sssetfirst nil ssfree)
    )
  )
  (princ)
)

[EDIT : I had lack... Changed to : (setq touchingblks (ssget "_F" (append pl (list (car pl))) '((0 . "INSERT")))) ]

Sir I ran this updated code @marko_ribar
But now it is not giving proper reporting of overlapping and also not highlighting overlapping blocks between zones.
See the below attached image ,it is just showing overlapping for Zone A.

I don't understand why this is happening?
What I am doing wrong ?

Edited March 31, 2020 by Skierz

March 31, 2020

2 hours ago, Skierz said:

The only thing I want is for block completely outside it should be highlighted

Code above is now adjusted to suit.

2 hours ago, Skierz said:

What I am doing wrong ?

Nothing. There's a small bug in that code.

Find the below in the code (line 28):

18 hours ago, marko_ribar said:

(setq touchingblks (ssget "_F" (append pl (list (car pl))) '((0 . "INSERT"))))

And replace it with:

(setq touchingblks (ssget "_F"
				  (if
				    (and
				      (eq (cdr (assoc 70 (entget (ssname sslws i)))) 1)
				      (null (equal (car pl) (last pl) 1))
				      )
				    (append pl (list (car pl)))
				    pl
				    )
				  '((0 . "INSERT"))
				  )
	      )

Issue is your polyline may appear closed, but it's actually not. You simply drew it closed, but if you check on the properties, the "Closed" property says "No" for zones B to D. You can try checking the "Closed" to "No" for zone A and see. Therefore by replacing the code to the above line, it escapes unclosed polylines.

(P.S. for whatever reason, idk why "F" can't catch if the last few points are the same. Seems weird. We'll wait for @Lee Macto provide us an answer.)

Feel free to try this:

(ssget "_F" (list (setq p1 (getpoint)) (setq p2 (getpoint p1)) p2))

Edited March 31, 2020 by Jonathan Handojo

March 31, 2020

53 minutes ago, Jonathan Handojo said:

Code above is now adjusted to suit.

@Jonathan Handojo Thank you for helping beginner like me.I really appreciate it.

55 minutes ago, Jonathan Handojo said:

Issue is your polyline may appear closed, but it's actually not. You simply drew it closed, but if you check on the properties, the "Closed" property says "No" for zones B to D. You can try checking the "Closed" to "No" for zone A and see. Therefore by replacing the code to the above line, it escapes unclosed polylines.

I noticed that in the property palette it is showing "No" in the closed property.I thought since the first and the last point are the same ,it will be closed but I was wrong.

1 hour ago, Jonathan Handojo said:

And replace it with:


(setq touchingblks (ssget "_F"
				  (if
				    (and
				      (eq (cdr (assoc 70 (entget (ssname sslws i)))) 1)
				      (null (equal (car pl) (last pl) 1))
				      )
				    (append pl (list (car pl)))
				    pl
				    )
				  '((0 . "INSERT"))
				  )
	      )

I have done this and now it is reporting correct,thanks
But still it is not highlighting overlapping zones block but never-mind your code is working absolutely amazing.
Have a nice day!

March 31, 2020

(ssget "_F" (list (setq p1 (getpoint)) (setq p2 (getpoint p1)) p2))

Actually my case is with p1 at the end like this :

(ssget "_F" (list (setq p1 (getpoint)) (setq p2 (getpoint p1)) p1))

But I don't know why in routine it fails... You are right if last points are same - (ssget "_F") returns nil... This too is weird...

March 31, 2020

6 minutes ago, marko_ribar said:

But I don't know why in routine it fails...

Take Zone D. It's not closed, so points are '(a b c d e f g) and g = a, so '(a b c d e f a), if (append pl (list (car pl))), then '(a b c d e f a a)

Edited March 31, 2020 by Jonathan Handojo

March 31, 2020

9 minutes ago, Jonathan Handojo said:

Take Zone D. It's not closed, so points are '(a b c d e) and e = a, so '(a b c d a), if (append pl (list (car pl))), then '(a b c d a a)

I see, thanks Jonathan...

I've changed my code with this revision :

(setq touchingblks (ssget "_F" (if (not (equal (car pl) (last pl))) (append pl (list (car pl))) pl) '((0 . "INSERT"))))

Edited March 31, 2020 by marko_ribar

March 31, 2020

4 hours ago, marko_ribar said:

You are right if last points are same - (ssget "_F") returns nil... This too is weird...

Actually, I just found out not because if the last few points are the same, but rather if the adjacent points are of zero length. I tried running a normal (ssget) and typed "F" for a fence selection. When I clicked on the same point, this popped up:

And it's not just "Fence", but even WPolygon or CPolygon, or probably anything that requires a list of points.

So even something like (ssget "_CP" (list p1 p2 p2 p3 p1)) or (ssget "_WP" (list p1 p2 p3 p4 p4 p1)) will fail.

Man, I need to revise all my LISP routines regarding this...

Edited March 31, 2020 by Jonathan Handojo

March 31, 2020

8 hours ago, Skierz said:

It is also good sir @ronjonp.
Thank you very much

Glad to help

April 1, 2020

Thank you all @marko_ribar @Jonathan Handojo @ronjonp for you help.
I will shout out if I need further help.

April 1, 2020

19 hours ago, Jonathan Handojo said:

Man, I need to revise all my LISP routines regarding this..

@Jonathan Handojo sir, I am facing one issue with your lisp code. If the polyline has width ,it does not highlight polylines while selecting objects and as well as when asking
"Select text specifying zone name for highlighted line or [Name]" .So ,it is quite difficult to select names since nothing is highlighted.
I am attaching the dwg file for your reference.
Thanks for consideration

Zones_Cadtutor_v3.dwg

April 1, 2020

16 minutes ago, Skierz said:

@Jonathan Handojo sir, I am facing one issue with your lisp code. If the polyline has width ,it does not highlight polylines while selecting objects and as well as when asking
"Select text specifying zone name for highlighted line or [Name]" .So ,it is quite difficult to select names since nothing is highlighted.
I am attaching the dwg file for your reference.
Thanks for consideration

Zones_Cadtutor_v3.dwg

It's actually highlighted, but hard to see. I didn't think I'd be using sssetfirst for this:

(defun c:notinside ( / *error* acadobj activeundo adoc ains alaps bb blk dets ent i ins j laprect laps maxpt minpt msg msp obname oneb orgblk pl plpt ss ssnotbl str vx x y zdet zname znames)

  ;; Error handling function
  (defun *error* ( msg )
    (sssetfirst nil nil)    
    (vla-EndUndoMark adoc)
    (if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*"))
      (princ (strcat "Error: " msg))
      )
    )
  (setq acadobj (vlax-get-acad-object)
        adoc (vla-get-ActiveDocument acadobj)
        msp (vla-get-ModelSpace adoc)
        activeundo nil)
  (if (= 0 (logand 8 (getvar "UNDOCTL"))) (vla-StartUndoMark adoc) (setq activeundo T))

  ;; Start function

  (if (setq ss (ssget '((0 . "INSERT,*POLYLINE"))))
    (progn
      (repeat (setq i (sslength ss))
        (if (eq (cdr (assoc 0 (entget (setq ent (ssname ss (setq i (1- i))))))) "INSERT")
          (setq blk (cons ent blk))
          (setq pl (cons ent pl))
          )
        )
      
      (setq orgblk (length blk))
      (foreach x pl
        
        ;; Get zone name

	(setq vx (vlax-ename->vla-object x))
        (sssetfirst nil (ssadd x))
        (while
          (progn
            (initget 1 "Name")
            (setq zname (entsel "\nSelect text specifying zone name for highlighted line or [Name]: "))
            (cond
              ((null zname) (princ "\nNothing selected"))
              ((eq zname "Name")
               (setq zname (getstring T "\nSpecify name for highlighted line: "))
               (if (vl-position zname znames)
                 (progn (princ (strcat "\nName \"" zname "\" already exist. Please enter a new name")) T)
                 (progn (setq znames (cons zname znames)) nil)
                 )
               )
              ((not (wcmatch (cdr (assoc 0 (entget (car zname)))) "TEXT,MTEXT")) (princ "\nObject is not a text"))
              ((setq zname (cdr (assoc 1 (entget (car zname)))))
               (if (vl-position zname znames)
                 (progn (princ (strcat "\nName \"" zname "\" already exist. Please enter a new name")) T)
                 (progn (setq znames (cons zname znames)) nil)
                 )
               )
              )
            )
          )
        
        ;; Get overlaps & Inside
        
        (vla-ZoomWindow acadobj
          (progn
            (vla-GetBoundingBox vx 'minpt 'maxpt)
            minpt
            )
          maxpt
          )
        (setq plpt (mapcar 'cdr (vl-remove-if-not '(lambda (y) (eq (car y) 10)) (entget x)))
              plpt (if (and (eq (cdr (assoc 70 (entget x))) 1) (null (equal (car plpt) (last plpt) 1))) (append plpt (list (car plpt))) plpt)
              laps (ssget "_F" plpt '((0 . "INSERT")))
              ins (ssget "_CP" plpt '((0 . "INSERT")))
              ains (cons ins ains)
              )

        (mapcar '(lambda (x y / bb)
                   (if (setq bb (ssget "_F" (list x y) '((0 . "INSERT"))))
                     (repeat (setq j (sslength bb))
                       (if (ssmemb (setq ent (ssname bb (setq j (1- j)))) ss)
                         (setq laprect (cons (apply 'JH:rectcorner (LM:ssboundingbox bb)) laprect))
                         )
                       )
                     )
                   )
                (reverse (cdr (reverse plpt)))
                (cdr plpt)
                )
        
        (vla-ZoomPrevious acadobj)
        
        (if laps
          (progn
            (repeat (setq i (sslength laps))
              (if (ssmemb (setq ent (ssname laps (setq i (1- i)))) ss)
                (setq alaps (cons (cons zname ent) alaps))
                )
              )
            
            )
          )
        
        (if ins
          (repeat (setq i (sslength ins))
            (setq blk (vl-remove (ssname ins (setq i (1- i))) blk))
            )
          )
        )

      (sssetfirst nil nil)
      
      ;; Get Details

      (setq ssnotbl (JH:list-to-selset blk))
      (while alaps
        (setq oneb (vl-remove-if-not '(lambda (x) (eq (cdr x) (cdar alaps))) alaps)
              dets (cons (cons (vla-get-EffectiveName (vlax-ename->vla-object (cdar alaps))) (LM:lst->str (vl-sort (mapcar 'car oneb) '(lambda (a b) (< a b))) ", ")) dets)
              alaps (vl-remove-if '(lambda (x) (eq (cdr x) (cdar alaps))) alaps)
              )
        )
      
      (setq obname (mapcar '(lambda (x) (vla-get-EffectiveName (vlax-ename->vla-object x))) blk)
            str (mapcar '(lambda (x)
                           (strcat "\n" (itoa (JH:CountSpecific zdet x)) " blocks overlapping on boundaries " x " ("
                                   (LM:lst->str (mapcar '(lambda (y) (strcat (itoa (cdr y)) " " (car y))) (LM:CountItems (mapcar 'car (vl-remove-if-not '(lambda (y) (eq x (cdr y))) dets)))) ", ")
                                   ")"
                                   )
                           )
                        (LM:Unique (setq zdet (mapcar 'cdr dets)))
                        )
            msg (strcat
                  "\nTotal number of blocks in selection: " (itoa orgblk)
                  "\nTotal number of zones identified: " (itoa (length pl)) " (" (cond ((LM:lst->str (vl-sort znames '(lambda (a b) (< a b))) ", ")) ("")) ")"
                  "\n"
                  "\nNumber of blocks outside zones: " (itoa (length blk)) " (" (cond ((LM:lst->str (mapcar '(lambda (x) (strcat (itoa (cdr x)) " " (car x))) (LM:CountItems obname)) ", ")) ("")) ")"
                  (apply 'strcat str)
                  "\n"
                  "\n"
                  "\nNumber of blocks outside and overlapping: " (itoa (+ (length blk)
                                                                          (length dets)
                                                                          )
                                                                       )
                  )
            )

      (entmake
        (list
          '(0 . "MTEXT")
          '(100 . "AcDbEntity")
          '(100 . "AcDbMText")
          (cons 1 msg)
          (cons 10 (progn (initget 1) (getpoint "\nSpecify insertion point for text: ")))
          '(40 . 2200)	; <--- Set text height here
          '(50 . 0)
          )
        )

      (foreach x (LM:UniqueFuzz laprect 1)
        (entmake
          (append
            '(
              (0 . "LWPOLYLINE")
              (100 . "AcDbEntity")
              (100 . "AcDbPolyline")
              (90 . 4)
              (70 . 1)
              (62 . 2)	; <--- Set color here. In this case, it's yellow. Depends on color index
              (43 . 300) ; <--- Set thickness here
              )
            (apply 'append
                   (mapcar '(lambda (y)
                              (list
                                (cons 10 y)
                                '(42 . 0)
                                '(91 . 0)
                                )
                              )
                           x
                           )
                   )
            )
          )
        )

      (sssetfirst nil ssnotbl)
      (princ msg)
      )
    )

  ;; End function
  
  (if activeundo nil (vla-EndUndoMark adoc))
  (princ)
  )

(defun JH:uniqueset (lst / fin)	; Returns a unique selection set from a list of selection sets
  (setq fin (ssadd))
  (mapcar '(lambda (x / a ent)
             (repeat (setq a (sslength x))
               (if (null (ssmemb (setq ent (ssname x (setq a (1- a)))) fin))
                 (setq fin (ssadd ent fin))
                 )
               )
             )
          lst
          )
  fin
  )

(defun JH:CountSpecific (lst itm)	; Returns the number of items itm is inside lst.
  (- (length lst)
     (length (vl-remove itm lst))
     )
  )


(defun JH:rectcorner (a b)
  (list
    a
    (list (car b) (cadr a) (last a))
    b
    (list (car a) (cadr b) (last a))
    )
  )

(defun JH:list-to-selset (lst / final)
  (setq final (ssadd))
  (mapcar '(lambda (x) (setq final (ssadd x final))) lst)
  final
  )

;; List to String  -  Lee Mac
;; Concatenates each string in a supplied list, separated by a given delimiter
;; lst - [lst] List of strings to concatenate
;; del - [str] Delimiter string to separate each item

(defun LM:lst->str ( lst del / str )
    (setq str (car lst))
    (foreach itm (cdr lst) (setq str (strcat str del itm)))
    str
)

;; Unique  -  Lee Mac
;; Returns a list with duplicate elements removed.

(defun LM:Unique ( l / x r )
    (while l
        (setq x (car l)
              l (vl-remove x (cdr l))
              r (cons x r)
        )
    )
    (reverse r)
)

;; Unique with Fuzz  -  Lee Mac
;; Returns a list with all elements considered duplicate to
;; a given tolerance removed.

(defun LM:UniqueFuzz ( l f / x r )
    (while l
        (setq x (car l)
              l (vl-remove-if (function (lambda ( y ) (equal x y f))) (cdr l))
              r (cons x r)
        )
    )
    (reverse r)
)

;; Count Items  -  Lee Mac
;; Returns a list of dotted pairs detailing the number of
;; occurrences of each item in a supplied list.

(defun LM:CountItems ( l / c l r x )
    (while l
        (setq x (car l)
              c (length l)
              l (vl-remove x (cdr l))
              r (cons (cons x (- c (length l))) r)
        )
    )
    (reverse r)
)

;; Selection Set Bounding Box  -  Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; sel - [sel] Selection set for which to return bounding box

(defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp )
    (repeat (setq idx (sslength sel))
        (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
        (if (and (vlax-method-applicable-p obj 'getboundingbox)
                 (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
            )
            (setq ls1 (cons (vlax-safearray->list llp) ls1)
                  ls2 (cons (vlax-safearray->list urp) ls2)
            )
        )
    )
    (if (and ls1 ls2)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
    )
)

Btw, the fence selection does not recognise by polyline width, so for example, if the below happens if the line is too thick, it won't catch it. For instance:

See the yellow cursor, which is actually the vertex point. Therefore my crosshair denotes the fence selection. The blue block is not touching the yellow line (the calculated fence selection), but it's touching the green polyline, so this is another issue if your polyline becomes too thick.

Edited April 1, 2020 by Jonathan Handojo

April 1, 2020

19 minutes ago, Jonathan Handojo said:

It's actually highlighted, but hard to see. I didn't think I'd be using sssetfirst for this:

Thanks for highlighting the issue @Jonathan Handojo.I didn't realize that I just wanted the polyline borders to be bolder in many cases that's why I thought of increasing the width.
Can you suggest any other alternative ?
Also, there is one more thing I want to request that the objects on locked layers should not be selected .Can we include such check ?

Sign In

Highlight & count blocks not inside polylines

Recommended Posts

Skierz

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

ronjonp

marko_ribar

Jonathan Handojo

Posted Images

marko_ribar

Skierz

Jonathan Handojo

Jonathan Handojo

ronjonp

Skierz

Skierz

Skierz

Jonathan Handojo

Skierz

marko_ribar

Jonathan Handojo

marko_ribar

Jonathan Handojo

ronjonp

Skierz

Skierz

Jonathan Handojo

Skierz

Join the conversation

ronjonp

marko_ribar

Jonathan Handojo

Tutorials

Forums

Activity