LOOKING FOR A CODE TO ASSIGN TEXT INSIDE A CLOSE POLYLINE AS LAYER SUFFIX

[Noor-Cad]

Hi All,

I am Glad to land on this page and this is my first post.

I am working on a project that has lot of closed polylines and each of this has a number (text) and some point inside and some point on the polyline.

looking for a code which will assign the text as suffix to the layers of the Points (inside and on Polyline).

Something like it will detect the number and assign the suffix for all the polylines.

 

With thanks

Noor

 

02_AFTER.dwg 01_BEFORE.dwg

Edited May 25, 2024 by Noor-Cad
dwgs attached

[devitg]

21 hours ago, Noor-Cad said:

Hi All,

I am Glad to land on this page and this is my first post.

I am working on a project that has lot of closed polylines and each of this has a number (text) and some point inside and some point on the polyline.

looking for a code which will assign the text as suffix to the layers of the Points (inside and on Polyline).

Something like it will detect the number and assign the suffix for all the polylines.

 

With thanks

Noor

 

02_AFTER.dwg 92.85 kB · 0 downloads 01_BEFORE.dwg 92.97 kB · 0 downloads

@Noor-Cad following

[BIGAL]

The dwg's look the same did you want "DRY-2162" as the answer ?

[Noor-Cad]

yes, need to change the layers

[Steven P]

Not sure if you want something like this?

 

 

No undo function which could be handy if there are lots of points

 

 

 

(defun c:test ( / currentzoom MyOut MyCoords MyLaySuff MyLay edMypoints MyEnt EntLay MyPoints MyPerimeterPoints MyPP)
  (defun mAssoc (key lst /)  ;;Returns list of 'key' values from supplied list
    (mapcar 'cdr (vl-remove-if-not (function (lambda (item) (= key (car item)))) lst))
  ) ; end massoc

  (defun LSZmObj  (ss / Minp Maxp lst)  ;;zooms to objects / selection set
    (foreach Obj  (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (vla-getBoundingBox Obj 'Minp 'Maxp)
      (setq lst (cons (mapcar 'vlax-safearray->list (list Minp Maxp)) lst)))
    (vla-ZoomWindow (vlax-get-acad-object)
      (vlax-3D-point (list (apply 'min (mapcar 'car (mapcar 'car lst))) (apply 'min (mapcar 'cadr (mapcar 'car lst)))  0.0))
      (vlax-3D-point (list (apply 'max (mapcar 'car (mapcar 'cadr lst)))(apply 'max (mapcar 'cadr (mapcar 'cadr lst))) 0.0))
    )
  )

  (defun CheckLayers ( MyLay MyLaySuff / )  ;;Checks if a layer exists else makes it. No layer transparency values applies.
    (if (tblobjname "LAYER" (strcat MyLay "-" MyLaySuff))
      () ; layer exists
      (progn
        (setq OldLayer (entget (tblobjname "LAYER" MyLay)))
        (setq OldLayer (entmakex (subst (cons 2 (strcat MyLay "-" MyLaySuff)) (assoc 2 OldLayer) OldLayer )))
      )
    )
  ) 

  (princ "Select Outline")                                  ;;Select the outline
  (setq MyOut (car (entsel)))                               ;;make the selection. Error if nothing is selected (LISP stops).
  (if (= (cdr (assoc 0 (entget MyOut))) "LWPOLYLINE")       ;;If the selection is a polyline continue
    (progn
      (setq currentzoom (list (getvar 'viewctr) (getvar 'viewsize)))  ;;Get current zoom
      (LSZmObj (ssadd MyOut))                               ;;Zoom to outline
      (setq MyCoords (mAssoc 10 (entget MyOut)))            ;;get list of outline coordinates
      (setq MyLaySuff (cdr (assoc 1 (entget (ssname (ssget "_CP" MyCoords '((0 . "TEXT"))) 0)))))  ;;get text string within the outline
      
      (setq ObjLay (cdr (assoc 8 (entget MyOut))) )         ;;Outline layer
      (CheckLayers ObjLay MyLaySuff)                        ;;Check if 'outlinelayer-suffix' layer exists else create it
      (setq ed (entget MyOut))                              ;;Outline deinition
      (setq ed (subst (cons 8 (strcat ObjLay "-" MyLaySuff)) (assoc 8 ed) ed ))  ;modify the outline layer
      (entmod ed)

      (setq MyPoints (ssget "_CP" MyCoords '((0 . "POINT")))) ;;Select internal points
;;      (setq MyPerimeterPoints (ssget "_F" MyCoords '((0 . "POINT")))) ;If required select points on outline
;;      (setq acount 0)                                     ;;Remove outline points from points selection if required
;;      (while (< acount (sslength MyPerimeterPoints))
;;        (setq MyPP (ssname MyPerimeterPoints acount))
;;        (setq MyPoints (ssdel MyPP MyPoints))
;;        (setq acount (+ acount 1))
;;      )
      (setq acount 0)                                       ;;A loop
      (while (< acount (sslength MyPoints))
        (setq MyEnt (ssname MyPoints acount))               ;;Each point in turn, 
        (setq EntLay (cdr (assoc 8 (entget MyEnt))))        ;;point on layer
        (CheckLayers EntLay MyLaySuff)                      ;;Check if layer exists else create it
        (setq ed (entget MyEnt))                            ;;get point definition
        (setq ed (subst (cons 8 (strcat EntLay "-" MyLaySuff)) (assoc 8 ed) ed )) ;;update its layer
        (entmod ed)
        (setq acount (+ acount 1))
      ) ; end while

      (vla-ZoomCenter (vlax-get-acad-object) (vlax-3d-point (car currentzoom)) (cadr currentzoom)) ;; return to previous zoom
    ) ; end progn
    (princ "PolyLine Outline No Selected")
  ) ; end if
  (princ)
)

 

[Noor-Cad]

On 5/28/2024 at 11:19 PM, Steven P said:

Not sure if you want something like this?

 

 

No undo function which could be handy if there are lots of points

 

 

 

(defun c:test ( / currentzoom MyOut MyCoords MyLaySuff MyLay edMypoints MyEnt EntLay MyPoints MyPerimeterPoints MyPP)
  (defun mAssoc (key lst /)  ;;Returns list of 'key' values from supplied list
    (mapcar 'cdr (vl-remove-if-not (function (lambda (item) (= key (car item)))) lst))
  ) ; end massoc

  (defun LSZmObj  (ss / Minp Maxp lst)  ;;zooms to objects / selection set
    (foreach Obj  (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (vla-getBoundingBox Obj 'Minp 'Maxp)
      (setq lst (cons (mapcar 'vlax-safearray->list (list Minp Maxp)) lst)))
    (vla-ZoomWindow (vlax-get-acad-object)
      (vlax-3D-point (list (apply 'min (mapcar 'car (mapcar 'car lst))) (apply 'min (mapcar 'cadr (mapcar 'car lst)))  0.0))
      (vlax-3D-point (list (apply 'max (mapcar 'car (mapcar 'cadr lst)))(apply 'max (mapcar 'cadr (mapcar 'cadr lst))) 0.0))
    )
  )

  (defun CheckLayers ( MyLay MyLaySuff / )  ;;Checks if a layer exists else makes it. No layer transparency values applies.
    (if (tblobjname "LAYER" (strcat MyLay "-" MyLaySuff))
      () ; layer exists
      (progn
        (setq OldLayer (entget (tblobjname "LAYER" MyLay)))
        (setq OldLayer (entmakex (subst (cons 2 (strcat MyLay "-" MyLaySuff)) (assoc 2 OldLayer) OldLayer )))
      )
    )
  ) 

  (princ "Select Outline")                                  ;;Select the outline
  (setq MyOut (car (entsel)))                               ;;make the selection. Error if nothing is selected (LISP stops).
  (if (= (cdr (assoc 0 (entget MyOut))) "LWPOLYLINE")       ;;If the selection is a polyline continue
    (progn
      (setq currentzoom (list (getvar 'viewctr) (getvar 'viewsize)))  ;;Get current zoom
      (LSZmObj (ssadd MyOut))                               ;;Zoom to outline
      (setq MyCoords (mAssoc 10 (entget MyOut)))            ;;get list of outline coordinates
      (setq MyLaySuff (cdr (assoc 1 (entget (ssname (ssget "_CP" MyCoords '((0 . "TEXT"))) 0)))))  ;;get text string within the outline
      
      (setq ObjLay (cdr (assoc 8 (entget MyOut))) )         ;;Outline layer
      (CheckLayers ObjLay MyLaySuff)                        ;;Check if 'outlinelayer-suffix' layer exists else create it
      (setq ed (entget MyOut))                              ;;Outline deinition
      (setq ed (subst (cons 8 (strcat ObjLay "-" MyLaySuff)) (assoc 8 ed) ed ))  ;modify the outline layer
      (entmod ed)

      (setq MyPoints (ssget "_CP" MyCoords '((0 . "POINT")))) ;;Select internal points
;;      (setq MyPerimeterPoints (ssget "_F" MyCoords '((0 . "POINT")))) ;If required select points on outline
;;      (setq acount 0)                                     ;;Remove outline points from points selection if required
;;      (while (< acount (sslength MyPerimeterPoints))
;;        (setq MyPP (ssname MyPerimeterPoints acount))
;;        (setq MyPoints (ssdel MyPP MyPoints))
;;        (setq acount (+ acount 1))
;;      )
      (setq acount 0)                                       ;;A loop
      (while (< acount (sslength MyPoints))
        (setq MyEnt (ssname MyPoints acount))               ;;Each point in turn, 
        (setq EntLay (cdr (assoc 8 (entget MyEnt))))        ;;point on layer
        (CheckLayers EntLay MyLaySuff)                      ;;Check if layer exists else create it
        (setq ed (entget MyEnt))                            ;;get point definition
        (setq ed (subst (cons 8 (strcat EntLay "-" MyLaySuff)) (assoc 8 ed) ed )) ;;update its layer
        (entmod ed)
        (setq acount (+ acount 1))
      ) ; end while

      (vla-ZoomCenter (vlax-get-acad-object) (vlax-3d-point (car currentzoom)) (cadr currentzoom)) ;; return to previous zoom
    ) ; end progn
    (princ "PolyLine Outline No Selected")
  ) ; end if
  (princ)
)

 

Thanks Steven,

This is doing good, Can you please update this to work on 3dpolylines also and next request is to avoid repeatedly adding the suffix if the suffix is already added to the layer or change the color of the selected objects to avoid repeating of the same objects.