assigning color (colour) to 2d plines - finding overlapping text

Merry Christmas everyone!

I'm looking for a way to solve 2 problems i have.

1) I'm working with contours and i'm looking for a lisp that can detect the 2d polylines or polylines that have the same elevation and assign them a predefined color.

For example

Elevation=1,6,10,100,1000 = blue

Elevation-2,7,20,200,2000 = color 32

Elevation=3,8,30,3000,3000= green

and so on....

I don't know if that will help but all the contours are in the same layer.

2) I have a lot of text entitties (not mtext) that many of them overlap eachother. So i'm looking for a routine that will identify these texts and higlight them or change their color so i can go and manually move them.

I would appreciate your help very much!

Thanks

this will try to solve your first problem

(vl-load-com)
(defun c:test (/ Elev SS)
 (princ "\nSelect contours: ")
 (if (setq SS (ssget (list (cons 0 "LWPOLYLINE"))))
   (foreach EntObj (mapcar 'vlax-ename->vla-object
		    (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
	    )
     (setq Elev (vla-get-Elevation EntObj))
     (vla-put-Color
EntObj
(cond ((vl-position Elev (list 1.0 6.0 10.0 100.0 1000.0)) 5)
      ((vl-position Elev (list 2.0 7.0 20.0 200.0 2000.0)) 32)
      ((vl-position Elev (list 3.0 8.0 30.0 3000.0 3000.0)) 3)
)
     )
   )
 )
 (princ)
)

And for the second part:

;; TextOverlap.lsp  CAB 12.27.07
;;  Circle Text overlap in current space
;;  Returns the list of circles created to flag the overlaps
(defun c:TOL() (c:TextOverlap))
(defun c:TextOverlap (/ ss *doc* lay olst obj1 obj2 intlst olf)
 (vl-load-com)
 ;;==============================================================
 ;;  return a list of intersect points
 ;;==============================================================
 (defun get_interpts (obj1 obj2 / iplist)
   (if (not (vl-catch-all-error-p
              (setq iplist (vl-catch-all-apply
                             'vlax-safearray->list
                             (list
                               (vlax-variant-value
                                 (vla-intersectwith obj1 obj2 acextendnone)
                               ))))))
     iplist
   )
 )

 (defun makecircle (pts)
   (entmakex (list (cons 0 "CIRCLE")
              (cons 8 "OVERLAP") 
              (cons 10 (list (car pts) (cadr pts)))
              (cons 40 10.0) ; radius
              )) 
 )
 
 (and (setq *doc* (vla-get-activedocument (vlax-get-acad-object)))
      (setq lay (vla-add (vla-get-layers *doc*) "OVERLAP"))
      (or (vla-put-color lay acred) t)
      (setq ss (ssget "_x"
                      (list (cons 0 "TEXT,MTEXT") (cons 410 (getvar "ctab")))))
      (setq olst (mapcar 'vlax-ename->vla-object (mapcar 'cadr (ssnamex ss))))
      (princ (strcat "\n" (itoa(length olst)) " items to process, Please wait....\n"))
      (while (setq obj1 (car olst) olst (cdr olst))
        (foreach obj2 olst
          (if (setq pts (get_interpts obj1 obj2))
            (setq intlst (cons (cons obj1 obj2) intlst)
                  olf (cons (makecircle pts) olf))
          )
        )
      )
 )
 olf
)

Thank you very much!

The second one works like a charm! I really appreciate it! Thanks CAB!

The first one works very nicely that is exactly what i wanted. But can you Vovka modify it so it works for both Polylines and 2DPolylines?

I may have both in the same drawing that have elevations.

Many many thanks

(vl-load-com)
(defun c:test (/ Elev SS)
 (princ "\nSelect contours: ")
 (if (setq SS (ssget (list (cons 0 "*POLYLINE"))))
   (foreach EntObj (mapcar 'vlax-ename->vla-object
		    (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
	    )
     (if (vlax-property-available-p EntObj 'Elevation)
(progn (setq Elev (vla-get-Elevation EntObj))
       ((lambda	(c)
	  (if c
	    (vla-put-Color EntObj c)
	  )
	)
	 (cond ((vl-position Elev (list 1.0 6.0 10.0 100.0 1000.0)) 5)
	       ((vl-position Elev (list 2.0 7.0 20.0 200.0 2000.0)) 32)
	       ((vl-position Elev (list 3.0 8.0 30.0 3000.0 3000.0)) 3)
	       (t nil)
	 )
       )
)
     )
   )
 )
 (princ)
)

PERFECT!

:wink:

Thank you both again!

Sorry to beat a dead horse here but I used the search and found this thread

I have tried running the "textoverlap.lsp" provided by CAB above but it does not seem to be working with my 2005 AutoCAD. I have a lot of text that is overlapping ontop of each other, does anyone have any lsp out there that can re-arrange all overlapping text?

I had a shot at this problem here.

Lee Mac,

Thank you for the response. I had to register with the Swamp before I could check it out. I'm thinking of the same text overlapping problem but is there anyway for the lisp to move the text so that they are no longer touching or within the drawn boundary box?

Thanks for the help!

I think it might be currently set to filter out checking with Text/MText, you might have to remove that from the filter list - I'm not sure how accurate it will be with text intersecting with text, as I haven't tested it this way - but let me know how you get on.

Maybe I'm asking my question wrong. Here is what I have got so far using your overlap.lsp.

First image shows the original DWG.

Second image shows what happens when I run overlap.lsp.

Third image shows what I would like for it to do.

I have looked for hours on something that can do that but can't find anything. Would something like this even be possible?

Is that after changing the filter?

I have modified the filter list, give this a try:

(defun c:overlap (/ *error* RotateByMatrix AddLwPoly BBox->List GroupByNum GetTextIns Point

                   ALLOBJS DOC FILTLST ILST LAYER LL NOBJ POLY PT R SPC SS UFLAG UR)
 
 ;; Lee Mac  ~  15.03.10
 (vl-load-com)

 (defun *error* (msg)
   (and uFlag (vla-EndUndomark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))    
 
 (setq layer "OverLapCheck")

 (setq FiltLst '((-4 . "<NOT") (0 . "VIEWPORT") (-4 . "NOT>")))

 (defun RotateByMatrix (obj pt ang / RotationMatrix Vector)
   ;; Rotation by Matrix  ~  Lee Mac 

   (setq RotationMatrix (list (list (cos ang) (- (sin ang))  0.0)
                              (list (sin ang)    (cos ang)   0.0)
                              (list    0.0           0.0     1.0)))

   (setq Vector (mapcar (function -) pt
                        (mapcar
                          (function
                            (lambda (row) (apply (function +)
                                                 (mapcar (function *) row pt))))
                          RotationMatrix)))
   (vla-transformby obj
     (vlax-tmatrix
       (append
         (mapcar
           (function
             (lambda (r x) (append r (list x))))

           RotationMatrix Vector)

         '((0.0 0.0 0.0 1.0))))))
 

 (defun AddLWPoly (blk lst)
   (vla-AddLightWeightPolyline blk
     (vlax-make-variant
       (vlax-safearray-fill
         (vlax-make-safearray vlax-vbDouble
           (cons 0 (1- (* 2 (length lst)))))
         (apply (function append) lst)))))
 

 (defun BBox->List (bbox)
   (  (lambda (bbox)
        (mapcar
          (function
            (lambda (funcs)
              (mapcar
                (function
                  (lambda (func)
                    (apply func bbox)))
                
                funcs)))
          
          '((caar  cadar)  (caadr cadar)
            (caadr cadadr) (caar  cadadr))))
     
     (list bbox)))
 

 (defun GroupByNum (lst num / rtn)
   (setq rtn nil)
   
   (if lst
     (cons (reverse
             (repeat num
               (progn
                 (setq rtn (cons (car lst) rtn)
                       lst (cdr lst))
                 rtn)))
           
           (GroupByNum lst num))))
 

 (defun GetTextIns (object)
   (vlax-get object
     (if (eq "AcDbText" (vla-get-ObjectName object))
       (if (eq acAlignmentLeft (vla-get-Alignment object))
         'InsertionPoint 'TextAlignmentPoint)
       'InsertionPoint)))
 

 (defun Point (pt)
   (entmakex (list (cons 0 "POINT")
                   (cons 8 layer)
                   (cons 10 pt)                    
                   (cons 62 2))))
 

 (defun SS->VLA (ss / i e lst)
   (setq i -1)
   (if ss
     (while (setq e (ssname ss (setq i (1+ i))))
       (setq lst (cons (vlax-ename->vla-object e) lst))))
   
   lst)  
 

 (setq doc (vla-get-ActiveDocument
             (vlax-get-acad-object))

       spc (if (or (eq acModelSpace (vla-get-ActiveSpace doc))
                   (eq :vlax-true   (vla-get-MSpace doc)))
             (vla-get-ModelSpace doc)
             (vla-get-PaperSpace doc)))  

 (or (tblsearch "LAYER" layer)
     (vla-add (vla-get-layers doc) layer))

 (setq AllObjs (ss->VLA (ssget "_X" FiltLst)))
 
 (if (ssget '((0 . "TEXT,MTEXT,INSERT")))
   (progn
     (setq uFlag (not (vla-StartUndoMark doc)))
     
     (vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))

       (if (not (zerop (setq r (+ (vla-get-Rotation obj)   
                                  (setq ucsx
                                    (if (eq (vla-get-Objectname obj) "AcDbMText")
                                      (angle '(0 0 0) (getvar 'UCSXDIR)) 0.))))))
         (progn
           (vla-put-rotation (setq nobj (vla-copy obj)) (- 0.0 ucsx))
           (vla-getBoundingBox nobj 'll 'ur)

           (RotateByMatrix              
             (setq Poly
               (AddLWPoly spc
                 (BBox->List
                   (mapcar (function vlax-safearray->list)
                           (list ll ur)))))

             (GetTextIns obj) r)
           
           (vla-put-layer Poly layer)
           (vla-put-Closed Poly :vlax-true)
           (vla-delete nobj))

         (progn
           (vla-getBoundingBox obj 'll 'ur)
           (vla-put-layer
             (setq Poly
               (AddLWPoly spc
                 (BBox->List
                   (mapcar (function vlax-safearray->list)
                           (list ll ur)))))
             layer)
           
           (vla-put-Closed Poly :vlax-true)))

       (if (setq iLst
                  (apply (function append)
                    (vl-remove-if (function null)
                      (mapcar
                        (function
                          (lambda (object)
                            (GroupByNum
                              (vlax-invoke Poly
                                'IntersectWith object acExtendNone) 3)))
                        
                        (vl-remove obj AllObjs)))))
         
         (progn              
           (vla-put-color Poly acRed)
           (mapcar (function Point) iLst))

         (vla-put-color Poly acGreen)))

     (vla-delete ss)
     (setq uFlag (vla-EndUndoMark doc))))

 (princ))

I changed the filter, removed the TEXT filter. When I do this it makes a red box around the text, not green like before. Same thing happens with the code you just posted. I will keep playing around with it, maybe I'm missing something here....

Exactly - indicating that the text overlaps...

It won't move the text - that's for you to do

I was afraid you would say that. The only problem is that I can have 500+ text overlaps. Oh well, I appreciate the help.