Moving Text Block to adjacent point

March 15, 2012

I use a very useful LISP by Pedro Ferreira called PMSFptwtxt which places a 3D point at the insertion point of a text string. It's great for processing point surveys which have been flattened, thus losing their elevation height.

Unfortunately the text label giving z-values for each point is usually not positioned correctly relative to the point which it describes, so the 3D points created are correct in z-value but not x and y. Most labels are consistently located (say top right) at a fixed distance from the point, but a few are below left or above centre etc. Having gone through labouriously finding and moving any rougue labels by eye, I started thinking there might be a more efficient way to acheive this.

If there was a recursive LISP that draws a line between the text insertion point and it's neighbouring point then I could filter the line lengths to find the atypical distances and fix these manually, then select the remaining labels and move them all together. The only tricky bit would be telling the LISP which point the text relates to. I'm guessing this could be done with some sort of delaunay/voronoi routine to find the nearest neighbour. I'm a LISP noob, so I'm not even sure if this is possible but any hints/opinions would be gratefully received...

Thanks in advance!

Tom

March 15, 2012

Why does the LISP have to be recursive?

Give this a try:

;; Text 2 Point  -  Lee Mac 2012
;; Prompts for a selection of Text and Point entities and moves
;; each Text entity to the nearest (2D distance) Point entity in the set.
;;
;; Retains existing Text elevation.

(defun c:txt2pt ( / _textinsertion di1 di2 dxf ent inc ins lst mpt pnt sel txt )

   (defun _textinsertion ( elist )
       (if
           (and
               (zerop (cdr (assoc 72 elist)))
               (zerop (cdr (assoc 73 elist)))
           )
           (cdr (assoc 10 elist))
           (cdr (assoc 11 elist))
       )
   )

   (if (setq sel (ssget "_:L" '((0 . "POINT,TEXT"))))
       (progn
           (repeat (setq inc (sslength sel))
               (setq ent (entget (ssname sel (setq inc (1- inc)))))
               (if (eq "POINT" (cdr (assoc 0 ent)))
                   (setq lst (cons (cdr (assoc 10 ent)) lst))
                   (setq txt (cons (cons (_textinsertion ent) ent) txt))
               )
           )
           (foreach ent txt
               (setq ins (list (caar ent) (cadar ent)))
               (if (setq pnt (vl-some '(lambda ( pnt ) (equal ins (list (car pnt) (cadr pnt)) 1e-8)) lst))
                   (setq lst (vl-remove pnt lst))
                   (progn
                       (setq di1 (distance ins (list (caar lst) (cadar lst)))
                             mpt (car lst)
                       )
                       (foreach pnt (cdr lst)
                           (if (< (setq di2 (distance ins (list (car pnt) (cadr pnt)))) di1)
                               (setq di1 di2
                                     mpt pnt
                               )
                           )
                       )
                       (setq pnt (list (car mpt) (cadr mpt) (caddar ent))
                             dxf (cdr ent)
                             dxf (subst (cons 10 pnt) (assoc 10 dxf) dxf)
                             dxf (subst (cons 11 pnt) (assoc 11 dxf) dxf)
                       )
                       (entmod dxf)
                       (setq lst (vl-remove mpt lst))
                   )
               )
           )
       )
   )
   (princ)
)
(vl-load-com) (princ)

It will prompt for a selection of Text and Point entities and move each Text entity to the nearest Point entity (nearest by 2D distance), unless a Point is already found with equal X/Y coords as the Text entity.

The program will retain the existing elevation of the Text entity.

Example:

It's probably not the most efficient routine, but I don't have time study a better algorithm.

Edited March 5, 2019 by Lee Mac

March 15, 2012

Absolutely perfect!

(and much quicker than my line drawing idea)

Thank you Lee Mac.

T

March 15, 2012

You're welcome

March 13, 2017

Why does the LISP have to be recursive?

Give this a try:

[color=GREEN];; Text 2 Point  -  Lee Mac 2012[/color]
[color=GREEN];; Prompts for a selection of Text and Point entities and moves[/color]
[color=GREEN];; each Text entity to the nearest (2D distance) Point entity in the set.[/color]
[color=GREEN];;[/color]
[color=GREEN];; Retains existing Text elevation.[/color]

([color=BLUE]defun[/color] c:txt2pt ( [color=BLUE]/[/color] _textinsertion di1 di2 dxf ent inc ins lst mpt pnt sel txt )

   ([color=BLUE]defun[/color] _textinsertion ( elist )
       ([color=BLUE]if[/color]
           ([color=BLUE]and[/color]
               ([color=BLUE]zerop[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 72 elist)))
               ([color=BLUE]zerop[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 73 elist)))
           )
           ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 10 elist))
           ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 11 elist))
       )
   )

   ([color=BLUE]if[/color] ([color=BLUE]setq[/color] sel ([color=BLUE]ssget[/color] [color=MAROON]"_:L"[/color] '((0 . [color=MAROON]"POINT,TEXT"[/color]))))
       ([color=BLUE]progn[/color]
           ([color=BLUE]repeat[/color] ([color=BLUE]setq[/color] inc ([color=BLUE]sslength[/color] sel))
               ([color=BLUE]setq[/color] ent ([color=BLUE]entget[/color] ([color=BLUE]ssname[/color] sel ([color=BLUE]setq[/color] inc ([color=BLUE]1-[/color] inc)))))
               ([color=BLUE]if[/color] ([color=BLUE]eq[/color] [color=MAROON]"POINT"[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 0 ent)))
                   ([color=BLUE]setq[/color] lst ([color=BLUE]cons[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 10 ent)) lst))
                   ([color=BLUE]setq[/color] txt ([color=BLUE]cons[/color] ([color=BLUE]cons[/color] (_textinsertion ent) ent) txt))
               )
           )
           ([color=BLUE]foreach[/color] ent txt
               ([color=BLUE]setq[/color] ins ([color=BLUE]list[/color] ([color=BLUE]caar[/color] ent) ([color=BLUE]cadar[/color] ent)))
               ([color=BLUE]if[/color] ([color=BLUE]setq[/color] pnt ([color=BLUE]vl-some[/color] '([color=BLUE]lambda[/color] ( pnt ) ([color=BLUE]equal[/color] ins ([color=BLUE]list[/color] ([color=BLUE]car[/color] pnt) ([color=BLUE]cadr[/color] pnt)) 1e-) lst))
                   ([color=BLUE]setq[/color] lst ([color=BLUE]vl-remove[/color] pnt lst))
                   ([color=BLUE]progn[/color]
                       ([color=BLUE]setq[/color] di1 ([color=BLUE]distance[/color] ins ([color=BLUE]list[/color] ([color=BLUE]caar[/color] lst) ([color=BLUE]cadar[/color] lst)))
                             mpt ([color=BLUE]car[/color] lst)
                       )
                       ([color=BLUE]foreach[/color] pnt ([color=BLUE]cdr[/color] lst)
                           ([color=BLUE]if[/color] ([color=BLUE]<[/color] ([color=BLUE]setq[/color] di2 ([color=BLUE]distance[/color] ins ([color=BLUE]list[/color] ([color=BLUE]car[/color] pnt) ([color=BLUE]cadr[/color] pnt)))) di1)
                               ([color=BLUE]setq[/color] di1 di2
                                     mpt pnt
                               )
                           )
                       )
                       ([color=BLUE]setq[/color] pnt ([color=BLUE]list[/color] ([color=BLUE]car[/color] mpt) ([color=BLUE]cadr[/color] mpt) ([color=BLUE]caddar[/color] ent))
                             dxf ([color=BLUE]cdr[/color] ent)
                             dxf ([color=BLUE]subst[/color] ([color=BLUE]cons[/color] 10 pnt) ([color=BLUE]assoc[/color] 10 dxf) dxf)
                             dxf ([color=BLUE]subst[/color] ([color=BLUE]cons[/color] 11 pnt) ([color=BLUE]assoc[/color] 11 dxf) dxf)
                       )
                       ([color=BLUE]entmod[/color] dxf)
                       ([color=BLUE]setq[/color] lst ([color=BLUE]vl-remove[/color] mpt lst))
                   )
               )
           )
       )
   )
   ([color=BLUE]princ[/color])
)
([color=BLUE]vl-load-com[/color]) ([color=BLUE]princ[/color])

It will prompt for a selection of Text and Point entities and move each Text entity to the nearest Point entity (nearest by 2D distance), unless a Point is already found with equal X/Y coords as the Text entity.

The program will retain the existing elevation of the Text entity.

Example:

[ATTACH]33660[/ATTACH]

It's probably not the most efficient routine, but I don't have time study a better algorithm.

Hi Lee,

I am trying to achieve the same but I need to also move the text level to the point's level.

Do you have a lsp routine to do this by any chance?

Thank you.

Harold

March 13, 2017

Hi Lee,

I am trying to achieve the same thing but I need to also move the text to the point's level.

Do you have a lsp routine that do this by any chance?

Thank you.

Harold

March 13, 2017

I am trying to achieve the same thing but I need to also move the text to the point's level.

Hi Harold,

Welcome to CADTutor

In the above code, simply change:

(setq pnt (list (car mpt) (cadr mpt) (caddar ent))

to:

(setq pnt mpt

This should achieve the desired result.

Lee

March 15, 2017

Thank you Lee.

March 15, 2017

No worries!

April 25, 2017

i fed searching for this over the internet and finally found this thread. my requirement is instead of moving to a point it should be move to nearest snap point like end or mid likewise. off topic question is there any options to create my own snap points like mid or end. Thank you.

March 5, 2019

On 3/15/2012 at 4:23 PM, Lee Mac said:

Why does the LISP have to be recursive?

Give this a try:


[color=GREEN];; Text 2 Point  -  Lee Mac 2012[/color]
[color=GREEN];; Prompts for a selection of Text and Point entities and moves[/color]
[color=GREEN];; each Text entity to the nearest (2D distance) Point entity in the set.[/color]
[color=GREEN];;[/color]
[color=GREEN];; Retains existing Text elevation.[/color]

([color=BLUE]defun[/color] c:txt2pt ( [color=BLUE]/[/color] _textinsertion di1 di2 dxf ent inc ins lst mpt pnt sel txt )

   ([color=BLUE]defun[/color] _textinsertion ( elist )
       ([color=BLUE]if[/color]
           ([color=BLUE]and[/color]
               ([color=BLUE]zerop[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 72 elist)))
               ([color=BLUE]zerop[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 73 elist)))
           ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 10 elist))
           ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 11 elist))
       )
   )

   ([color=BLUE]if[/color] ([color=BLUE]setq[/color] sel ([color=BLUE]ssget[/color] [color=MAROON]"_:L"[/color] '((0 . [color=MAROON]"POINT,TEXT"[/color]))))
       ([color=BLUE]progn[/color]
           ([color=BLUE]repeat[/color] ([color=BLUE]setq[/color] inc ([color=BLUE]sslength[/color] sel))
               ([color=BLUE]if[/color] ([color=BLUE]eq[/color] [color=MAROON]"POINT"[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 0 ent)))
                   ([color=BLUE]setq[/color] lst ([color=BLUE]cons[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 10 ent)) lst))
                   ([color=BLUE]setq[/color] txt ([color=BLUE]cons[/color] ([color=BLUE]cons[/color] (_textinsertion ent) ent) txt))
               )
           )
           ([color=BLUE]foreach[/color] ent txt
               ([color=BLUE]setq[/color] ins ([color=BLUE]list[/color] ([color=BLUE]caar[/color] ent) ([color=BLUE]cadar[/color] ent)))
               ([color=BLUE]if[/color] ([color=BLUE]setq[/color] pnt ([color=BLUE]vl-some[/color] '([color=BLUE]lambda[/color] ( pnt ) ([color=BLUE]equal[/color] ins ([color=BLUE]list[/color] ([color=BLUE]car[/color] pnt) ([color=BLUE]cadr[/color] pnt)) 1e-) lst))
                       ([color=BLUE]setq[/color] di1 ([color=BLUE]distance[/color] ins ([color=BLUE]list[/color] ([color=BLUE]caar[/color] lst) ([color=BLUE]cadar[/color] lst)))
                             mpt ([color=BLUE]car[/color] lst)
                       )
                           ([color=BLUE]if[/color] ([color=BLUE]<[/color] ([color=BLUE]setq[/color] di2 ([color=BLUE]distance[/color] ins ([color=BLUE]list[/color] ([color=BLUE]car[/color] pnt) ([color=BLUE]cadr[/color] pnt)))) di1)
                               ([color=BLUE]setq[/color] di1 di2
                                     mpt pnt
                               )
                           )
                       )
([color=BLUE]vl-load-com[/color]) ([color=BLUE]princ[/color])

It will prompt for a selection of Text and Point entities and move each Text entity to the nearest Point entity (nearest by 2D distance), unless a Point is already found with equal X/Y coords as the Text entity.

The program will retain the existing elevation of the Text entity.

Example:

It's probably not the most efficient routine, but I don't have time study a better algorithm.

March 5, 2019

hello , i want to take that lisp to move points with diffrent distances
i copy that text and save it as .lsp and when i app load

March 5, 2019

14 hours ago, mohamed_ashraf said:

hello , i want to take that lisp to move points with diffrent distances
i copy that text and save it as .lsp and when i app load

I've updated the code in my post to remove the BBCode and correct the 1e-8 issues following the "upgrade" of the forum software.

July 1, 2019

Reference linie would be nice

July 1, 2019

3 hours ago, urbat said:

Reference linie would be nice

Not sure what you mean?

July 2, 2019

or similar

July 2, 2019

11 hours ago, urbat said:

or similar

This actually only requires a relatively small modification -

;; Text 2 Point  -  Lee Mac 2012
;; Prompts for a selection of Text and Point entities and moves
;; each Text entity to the nearest (2D distance) Point entity in the set.
;;
;; Retains existing Text elevation.

(defun c:txt2pt ( / _textinsertion di1 di2 dxf ent inc ins lst mpt pnt sel txt )

   (defun _textinsertion ( elist )
       (if
           (and
               (zerop (cdr (assoc 72 elist)))
               (zerop (cdr (assoc 73 elist)))
           )
           (cdr (assoc 10 elist))
           (cdr (assoc 11 elist))
       )
   )

   (if (setq sel (ssget "_:L" '((0 . "POINT,TEXT"))))
       (progn
           (repeat (setq inc (sslength sel))
               (setq ent (entget (ssname sel (setq inc (1- inc)))))
               (if (eq "POINT" (cdr (assoc 0 ent)))
                   (setq lst (cons (cdr (assoc 10 ent)) lst))
                   (setq txt (cons (cons (_textinsertion ent) ent) txt))
               )
           )
           (foreach ent txt
               (setq ins (list (caar ent) (cadar ent)))
               (if (setq pnt (vl-some '(lambda ( pnt ) (equal ins (list (car pnt) (cadr pnt)) 1e-8)) lst))
                   (setq lst (vl-remove pnt lst))
                   (progn
                       (setq di1 (distance ins (list (caar lst) (cadar lst)))
                             mpt (car lst)
                       )
                       (foreach pnt (cdr lst)
                           (if (< (setq di2 (distance ins (list (car pnt) (cadr pnt)))) di1)
                               (setq di1 di2
                                     mpt pnt
                               )
                           )
                       )
                       (setq pnt (list (car mpt) (cadr mpt) (caddar ent))
;;;                             dxf (cdr ent)
;;;                             dxf (subst (cons 10 pnt) (assoc 10 dxf) dxf)
;;;                             dxf (subst (cons 11 pnt) (assoc 11 dxf) dxf)
                       )
;;;                       (entmod dxf)
                       (entmake (list '(0 . "LINE") (cons 10 ins) (cons 11 pnt)))
                       (setq lst (vl-remove mpt lst))
                   )
               )
           )
       )
   )
   (princ)
)
(vl-load-com) (princ)

July 3, 2019

But text don't move.

I want to see where the text moves.

THX

November 12, 2019

Good afternoon,

Can this LSP be modified to move a block reference in a similar manner? My problem is with surveyed points where the blocks, for manholes, trees, etc, always come in at zero elevation, however a node comes in at the correct elevation. I would like the blocks to move to the same elevation as the nodes. The insertion point of the block sits in the same horizontal position as the node.

Thanks,

Chris

November 12, 2019

2 hours ago, Chris Hall said:

Good afternoon,

Can this LSP be modified to move a block reference in a similar manner? My problem is with surveyed points where the blocks, for manholes, trees, etc, always come in at zero elevation, however a node comes in at the correct elevation. I would like the blocks to move to the same elevation as the nodes. The insertion point of the block sits in the same horizontal position as the node.

Thanks,

Chris

Try this adaption of Lee's code. Minimally tested.

(vl-load-com)

(defun c:blk2pt ( / ss fuzz cnt obj p_lst b_lst blk pt i_pt dist d)

  (setq ss (ssget ":L" '((0 . "POINT,INSERT")))
        fuzz 1.0e-6
  );end_setq

  (cond (ss 
          (repeat (setq cnt (sslength ss))
            (setq obj (vlax-ename->vla-object (ssname ss (setq cnt (1- cnt)))))
            (if (wcmatch (strcase (vlax-get-property obj 'objectname)) "*POINT")
              (setq p_lst (cons (vlax-get obj 'coordinates) p_lst))
              (setq b_lst (cons (list (vlax-get obj 'insertionpoint) obj) b_lst))
            );end_if
          );end_repeat
          (foreach pr b_lst
            (setq blk (cadr pr) pt (car pr) i_pt nil)
            (cond ( (setq i_pt (vl-some '(lambda (x) (equal pt x fuzz)) p_lst))
                    (setq p_lst (vl-remove i_pt p_lst))
                    (vlax-put blk 'insertionpoint i_pt)
                  )
                  (t  (setq i_pt (car p_lst)
                            dist (distance pt (reverse (cdr (reverse i_pt))))
                      );end_setq
                      (foreach p (cdr p_lst)
                        (if (< (setq d (distance pt (reverse (cdr (reverse p))))) dist)
                          (setq i_pt p dist d)
                        );end_if
                      );end_foreach
                      (setq p_lst (vl-remove i_pt p_lst))
                      (vlax-put blk 'insertionpoint i_pt)
                  )
            );end_cond
          );end_foreach
        )
  );end_cond
  (princ)
);end_defun

Sign In

Moving Text Block to adjacent point

Recommended Posts

archipelag0

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

Lee Mac

Lee Mac

GTVic

Posted Images

Lee Mac

archipelag0

Lee Mac

HaroldA

HaroldA

Lee Mac

HaroldA

Lee Mac

madhuchelliah

mohamed_ashraf

mohamed_ashraf

Lee Mac

urbat

Lee Mac

urbat

Lee Mac

urbat

Chris Hall

dlanorh

Join the conversation

Lee Mac

Lee Mac

GTVic

Tutorials

Forums

Activity