Moving Text Block to adjacent point

[BIGAL]

I would suggest a different way ssget points, then use ssget "F" "insert" this finds the closest insert to the point as the "fence" can be tuned in terms of size. Then just change Z of Insertionpoint. Very short code.

 

Similar problem 

 

 

Edited November 12, 2019 by BIGAL

[Chris Hall]

Thank you so much, works like a charm!

 

Chris

[Bojidar]

Hello,

 

This is really helpful. However, I have the problem that some of the text is aligned and rotated and the lisp uses its Alignment coordinates (Text alignment X and Text alignment Y) as the basepoint to move it to the point. Is there a way to use the text Position (Position X and Posiotion Y) coordinates instead?

[Least]

Hi Lee

 

The txt2pnt lisp, I was wondering if a max search radius could be added, so after a predefined distance the lisp would then give up trying to find a match for that point and move on.

Its agreat lisp when every point has corresponding text, but no when the data doesn't conform.

 

It would be a great additon to an already useful lisp.

 

Many thanks

Pads

[Lee Mac]

1 hour ago, Least said:

The txt2pnt lisp, I was wondering if a max search radius could be added, so after a predefined distance the lisp would then give up trying to find a match for that point and move on.

Its agreat lisp when every point has corresponding text, but no when the data doesn't conform.

 

Here's a quick 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 mrd pnt sel txt )

    (setq mrd 10.0) ;; Maximum permissible distance

   (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
                               )
                           )
                       )
                       (if (< di1 mrd)
                           (progn
                               (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)

 

[Least]

Brilliant.  Thanks Lee!

P

[GTVic]

Someone asked me for a modified version so I'm posting it here with thanks to Lee Mac.

• prompts for maximum movement distance
• allows MTEXT and Civil 3D Cogo Points
• only modifies group code 10 or 11, not both

;; 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 _pointinsertion di1 di2 dxf dcd ent entname inc ins lst mpt mrd pnt sel txt )

   (setq mrd 10.0) ;; Maximum permissible distance

   (defun _textinsertion ( elist )
       (if
           (or (= "MTEXT" (cdr (assoc 0 elist)))
               (and
                   (zerop (cdr (assoc 72 elist)))
                   (zerop (cdr (assoc 73 elist)))
               )
           )
           (assoc 10 elist)
           (assoc 11 elist)
       )
   )

   (defun _pointinsertion ( ename elist / vp res )
       (if (= "AECC_COGO_POINT" (cdr (assoc 0 elist)))
         (setq vp  (vlax-ename->vla-object ename)
               res (list (vlax-get-property vp 'Easting)
                         (vlax-get-property vp 'Northing)
                         (vlax-get-property vp 'Elevation)))
         (setq res (cdr (assoc 10 elist)))))
         
   (setq mrd
       (cond
           ((getreal (strcat "\nMaximum move distance <" (rtos mrd 2 1) ">: ")))
           (mrd)
       )
   )

   (princ "\nSelect point and text objects...\n")
   (if (setq sel (ssget "_:L" '((0 . "POINT,TEXT,AECC_COGO_POINT,MTEXT"))))
       (progn
           (repeat (setq inc (sslength sel))
               (setq ent (entget (setq entname (ssname sel (setq inc (1- inc))))))
               (if (or 
                       (eq "POINT" (cdr (assoc 0 ent)))
                       (eq "AECC_COGO_POINT" (cdr (assoc 0 ent)))
                   )
                   (setq lst (cons (_pointinsertion entname ent) lst))
                   (setq txt (cons (cons (_textinsertion ent) ent) txt))
               )
           )
           (foreach ent txt
               (setq ins (list (cadar ent) (caddar 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
                               )
                           )
                       )
                       (if (< di1 mrd)
                           (progn
                               (setq pnt (list (car mpt) (cadr mpt) (caddar ent))
                                     dcd (caar ent)
                                     dxf (cdr ent)
                                     dxf (subst (cons dcd pnt) (assoc dcd dxf) dxf)
                               )
                               (entmod dxf)
                               (setq lst (vl-remove mpt lst))
                           )
                       )
                   )
               )
           )
       )
   )
   (princ)
)
(vl-load-com) (princ)

 

[HOACH]

On 30/05/2020 at 19:57, Lee Mac said:

 

Here's a quick 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 mrd pnt sel txt )

    (setq mrd 10.0) ;; Maximum permissible distance

   (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
                               )
                           )
                       )
                       (if (< di1 mrd)
                           (progn
                               (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)

 

Hi, Lee

 

I am trying to achieve the same thing but I need to also move the blocks to the points

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

 

Thank you.

[3dwannab]

Another mod of the original code from Lee Mac (Thanks).

 

Comments in the header.

 

;; https://www.cadtutor.net/forum/topic/37515-moving-text-block-to-adjacent-point/?do=findComment&comment=566551

;; 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.
;;
;; MODIFICATIONS BY 3DWANNAB
;;
;; Modified on 2022.11.18 by 3dwannab.
;;  - Added INSERT along with POINT to the selection.
;;  - Added undo handling.
;;  - Prompt to pick fuzz value.
;;  - Retain slection after the command.
;;
;; Modified on 2022.12.09 by 3dwannab.
;;  - Added MTEXT to program.
;;
;; Credit to Lee Mac for the original coede
;;

(defun c:Text_2_Point_Or_Block (/ *error* acDoc _textinsertion dcd di1 di2 dxf ent entname inc ins lst pnt regFuzz sel txt)

  (defun *error* (errmsg)
    (and acDoc (vla-EndUndoMark acDoc))
    (and errmsg
         (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*"))
         (princ (strcat "\n<< Error: " errmsg " >>\n"))
    )
  )

  (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc))

  ;; Get saved value from the registry or default to 1
  (setq regFuzz (read (cond ((getenv "Text_2_Point_Or_Block_Fuzz_Value")) (1))))

  (setq regFuzz (cond
                  ((getdist
                     (strcat "\nPick or enter the gap tolerance to move the TEXT to POINTS or BLOCKS :\nCurrent value <"
                             (vl-princ-to-string (getenv "Text_2_Point_Or_Block_Fuzz_Value"))
                             ">: "
                     )
                   )
                  )
                  (regFuzz)
                )
  )

  ;; Set the registry value to the variable
  (setenv "Text_2_Point_Or_Block_Fuzz_Value" (vl-princ-to-string regFuzz))

  (defun _textinsertion (elist)
    (if
      (or (= "MTEXT" (cdr (assoc 0 elist)))
          (and
            (zerop (cdr (assoc 72 elist)))
            (zerop (cdr (assoc 73 elist)))
          )
      )
      (assoc 10 elist)
      (assoc 11 elist)
    )
  )

  (princ "\nSelect point and text objects...\n")
  (if (setq sel (ssget "_:L" '((0 . "POINT,INSERT,TEXT,MTEXT"))))
    (progn
      (repeat (setq inc (sslength sel))
        (setq ent (entget (setq entname (ssname sel (setq inc (1- inc))))))
        (if
          (or
            (eq "POINT" (cdr (assoc 0 ent)))
            (eq "INSERT" (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 (cadar ent) (caddar 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
                )
              )
            )
            (if (< di1 regFuzz)
              (progn
                (setq pnt (list (car mpt) (cadr mpt) (caddar ent))
                      dcd (caar ent)
                      dxf (cdr ent)
                      dxf (subst (cons dcd pnt) (assoc dcd dxf) dxf)
                )
                (entmod dxf)
                (setq lst (vl-remove mpt lst))
              )
            )
          )
        )
      )
    )
  )
  (sssetfirst nil sel)
  (command "_.REGEN")
  (*error* nil)
)
(vl-load-com)
(princ)

; (c:Text_2_Point_Or_Block) ;; Use for testing only

 

[aarong85]

On 12/9/2022 at 3:27 AM, 3dwannab said:

Another mod of the original code from Lee Mac (Thanks).

 

Comments in the header.

 

;; https://www.cadtutor.net/forum/topic/37515-moving-text-block-to-adjacent-point/?do=findComment&comment=566551

;; 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.
;;
;; MODIFICATIONS BY 3DWANNAB
;;
;; Modified on 2022.11.18 by 3dwannab.
;;  - Added INSERT along with POINT to the selection.
;;  - Added undo handling.
;;  - Prompt to pick fuzz value.
;;  - Retain slection after the command.
;;
;; Modified on 2022.12.09 by 3dwannab.
;;  - Added MTEXT to program.
;;
;; Credit to Lee Mac for the original coede
;;

(defun c:Text_2_Point_Or_Block (/ *error* acDoc _textinsertion dcd di1 di2 dxf ent entname inc ins lst pnt regFuzz sel txt)

  (defun *error* (errmsg)
    (and acDoc (vla-EndUndoMark acDoc))
    (and errmsg
         (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*"))
         (princ (strcat "\n<< Error: " errmsg " >>\n"))
    )
  )

  (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc))

  ;; Get saved value from the registry or default to 1
  (setq regFuzz (read (cond ((getenv "Text_2_Point_Or_Block_Fuzz_Value")) (1))))

  (setq regFuzz (cond
                  ((getdist
                     (strcat "\nPick or enter the gap tolerance to move the TEXT to POINTS or BLOCKS :\nCurrent value <"
                             (vl-princ-to-string (getenv "Text_2_Point_Or_Block_Fuzz_Value"))
                             ">: "
                     )
                   )
                  )
                  (regFuzz)
                )
  )

  ;; Set the registry value to the variable
  (setenv "Text_2_Point_Or_Block_Fuzz_Value" (vl-princ-to-string regFuzz))

  (defun _textinsertion (elist)
    (if
      (or (= "MTEXT" (cdr (assoc 0 elist)))
          (and
            (zerop (cdr (assoc 72 elist)))
            (zerop (cdr (assoc 73 elist)))
          )
      )
      (assoc 10 elist)
      (assoc 11 elist)
    )
  )

  (princ "\nSelect point and text objects...\n")
  (if (setq sel (ssget "_:L" '((0 . "POINT,INSERT,TEXT,MTEXT"))))
    (progn
      (repeat (setq inc (sslength sel))
        (setq ent (entget (setq entname (ssname sel (setq inc (1- inc))))))
        (if
          (or
            (eq "POINT" (cdr (assoc 0 ent)))
            (eq "INSERT" (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 (cadar ent) (caddar 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
                )
              )
            )
            (if (< di1 regFuzz)
              (progn
                (setq pnt (list (car mpt) (cadr mpt) (caddar ent))
                      dcd (caar ent)
                      dxf (cdr ent)
                      dxf (subst (cons dcd pnt) (assoc dcd dxf) dxf)
                )
                (entmod dxf)
                (setq lst (vl-remove mpt lst))
              )
            )
          )
        )
      )
    )
  )
  (sssetfirst nil sel)
  (command "_.REGEN")
  (*error* nil)
)
(vl-load-com)
(princ)

; (c:Text_2_Point_Or_Block) ;; Use for testing only

 

i try to run this lisp but it´is appear an error message:  << Error: bad argument type: stringp 1 >>, can you help me please

[3dwannab]

@aarong85, try placing (vl-load-com) at the top of the code.

[3dwannab]

@aarong85 try this. I sometimes struggle with writing and reading to and from the registry.

 

;; https://www.cadtutor.net/forum/topic/37515-moving-text-block-to-adjacent-point/?do=findComment&comment=566551

;; 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.
;;
;; MODIFICATIONS BY 3DWANNAB
;; Link https://www.cadtutor.net/forum/topic/37515-moving-text-block-to-adjacent-point/?do=findComment&comment=605448
;;
;; Modified on 2022.11.18 by 3dwannab.
;;  - Added INSERT along with POINT to the selection.
;;  - Added undo handling.
;;  - Prompt to pick fuzz value.
;;  - Retain slection after the command.
;;
;; Modified on 2023.03.30 by 3dwannab.
;;  - Added MTEXT and CIRCLES to the program.
;;
;; Modified on 2024.05.14 by 3dwannab.
;;  - Added a while loop to the program to allow user to choose different fuzz distance values.
;;  - Added selection of the modified objects after the code has finished. Handled in the error handler.
;;
;; Credit to Lee Mac for the original coede
;;

(vl-load-com)

(defun c:Text_2_Point_Or_Block (/ *error* acDoc _textinsertion _MergeSelectionSets dcd di1 di2 dxf ent entname inc ins lst pnt regFuzz ss1 txt ListOfSSs) 

  (defun *error* (errmsg) 
    (and acDoc (vla-EndUndoMark acDoc))
    (and errmsg 
         (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*"))
         (princ (strcat "\n<< Error: " errmsg " >>\n"))
    )

    (if ListOfSSs 
      (progn 
        (sssetfirst nil (_MergeSelectionSets ListOfSSs))
        (command-s "_.REGEN")
      )
    )
  )

  (defun _textinsertion (elist) 
    (if 
      (or (= "MTEXT" (cdr (assoc 0 elist))) 
          (and 
            (zerop (cdr (assoc 72 elist)))
            (zerop (cdr (assoc 73 elist)))
          )
      )
      (assoc 10 elist)
      (assoc 11 elist)
    )
  )

  ;; Credit: https://www.cadtutor.net/forum/profile/23626-grrr/
  ;; https://www.cadtutor.net/forum/topic/61683-adding-selection-set-items-to-one-set/?do=findComment&comment=509167
  (defun _MergeSelectionSets (ListOfSSs / Lst nSS) 
    (if (apply 'and (mapcar '(lambda (x) (= 'PICKSET (type x))) ListOfSSs)) 
      (progn 
        (setq nSS (ssadd))
        (mapcar 
          (function 
            (lambda (x / i) 
              (repeat (setq i (sslength x)) 
                (ssadd (ssname x (setq i (1- i))) nSS)
              )
            )
          )
          ListOfSSs
        )
      )
    )
    nSS
  )

  (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc))

  (while 

    (progn 

      ;; Get saved value from the registry or default to 1
      (setq regFuzz (read (cond ((getenv "Text_2_Point_Or_Block_Fuzz_Value")) (1))))

      (setq regFuzz (cond 
                      ((getdist 
                         (strcat "\nPick or enter the gap tolerance to move the TEXT to POINTS or BLOCKS :\nCurrent value <" 
                                 (vl-princ-to-string (getenv "Text_2_Point_Or_Block_Fuzz_Value"))
                                 ">: "
                         )
                       )
                      )
                      (regFuzz)
                    )
      )

      ;; Set the registry value to the variable
      (setenv "Text_2_Point_Or_Block_Fuzz_Value" (vl-princ-to-string regFuzz))

      (princ "\nSelect point and text objects...\n")
      (if (setq ss1 (ssget "_:L" '((0 . "POINT,INSERT,CIRCLE,TEXT,MTEXT")))) 
        (progn 
          (repeat (setq inc (sslength ss1)) 
            (setq ent (entget (setq entname (ssname ss1 (setq inc (1- inc))))))
            (if 
              (or 
                (eq "POINT" (cdr (assoc 0 ent)))
                (eq "CIRCLE" (cdr (assoc 0 ent)))
                (eq "INSERT" (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 (cadar ent) (caddar 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
                    )
                  )
                )
                (if (< di1 regFuzz) 
                  (progn 
                    (setq pnt (list (car mpt) (cadr mpt) (caddar ent))
                          dcd (caar ent)
                          dxf (cdr ent)
                          dxf (subst (cons dcd pnt) (assoc dcd dxf) dxf)
                    )
                    (entmod dxf)
                    (setq lst (vl-remove mpt lst))
                  )
                )
              ) ;; progn
            ) ;; if pnt
          ) ;; foreach
        ) ;; progn
      ) ;; if selection
      (setq ListOfSSs (cons ss1 ListOfSSs))
    ) ;; progn
  ) ;; while

  (*error* nil)

  (princ)
) ;; defun

; (c:Text_2_Point_Or_Block) ;; Use for testing only

 

Edited May 14 by 3dwannab
Updated code

[Tony M]

Text 2 point is a brilliant lisp that I use on a regular basis; would it be possible to add to the routine so the moved text colour would change to green and rotate to 0?

 

[Lee Mac]

4 hours ago, Tony M said:

Text 2 point is a brilliant lisp that I use on a regular basis; would it be possible to add to the routine so the moved text colour would change to green and rotate to 0?

 

 

Hi Tony,

 

Which code are you using? My original code from this post?

[Tony M]

Hi Lee

 

Many thanks for replying and for creating this lisp, it has been really useful over the last few years!

 

Your original one I thinktxt2pt.lsp

[Lee Mac]

6 hours ago, Tony M said:

Many thanks for replying and for creating this lisp, it has been really useful over the last few years!

 

Your original one I thinktxt2pt.lsp

 

I'm delighted to hear that you find the program useful after all these years!

 

Here's a tweak to rotate the text to 0 degrees and change the colour to green:

;; 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)
                              dxf (subst '(50 . 0.0)    (assoc 50 dxf) dxf)
                              dxf (if (assoc 62 dxf) (subst '(62 . 3) (assoc 62 dxf) dxf) (append dxf '((62 . 3))))
                        )
                        (entmod dxf)
                        (setq lst (vl-remove mpt lst))
                    )
                )
            )
        )
    )
    (princ)
)
(vl-load-com) (princ)

 

[Tony M]

Works perfectly, thanks Lee.

[Lee Mac]

You're welcome Tony, glad to help.

[asdfgh]

On 6/30/2023 at 12:45 PM, Lee Mac said:

You're welcome Tony, glad to help.

Heey @Lee Mac,

First of all i am really a big fan of yours, you really help so much with your genius lisp solutions. I wish you always success.

I am wondering if your lisp can move texts and lines too, here is the case

 

Sample.dwg

Edited July 6, 2023 by asdfgh

[BIGAL]

If you look into the command in VL lisp getclosestpointto that is the answer for this problem, just select the 3 objects, point, line & text. then based on the Line get the new point and move the text and object to the respective point.

 

The line with 10 may end up with the point on top of the 10.

 

Bit busy at moment will add to To do but some one else may jump in.

Edited July 8, 2023 by BIGAL