Moving Text Block to adjacent point

July 7, 2023

18 hours ago, BIGAL said:

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.

thank you for your reply,

isn't there a way to select all the text, lines & points in the drawing at once ? as i have hundreds of this case

July 8, 2023

Can be done, probably use the text as the search point then look for a Line and a point. Only issue is if point is to far away.

Did a bit of testing not finished yet been busy.

July 8, 2023

Try this

(defun c:wow ( / ss ss2 pt pt2 pt3 pt4 pt5 obj1 obj2 obj3 pttxt getline getpt)

(defun getline (pt1 / pt2 pt3 pt4 pt5)
  (setq pt2 (polar pt1 (* 0.25 pi) 700))
  (setq pt3 (polar pt1 (* 0.75 pi) 700))
  (setq pt4 (polar pt1 (* 1.25 pi) 700))
  (setq pt5 (polar pt1 (* 1.75 pi) 700))
  (setq ss2 (ssget "F" (list pt2 pt3 pt4 pt5 pt2) (list (cons 0  "LINE"))))
  (setq obj2 (vlax-ename->vla-object (ssname ss2 0)))
  (setq pt2 (vlax-curve-getclosestpointto obj2 pttxt))
  (vla-move  obj1 (vlax-3d-point pttxt) (vlax-3d-point pt2))
)

(defun getpt (pt1 / pt2 pt3 pt4 pt5)
  (setq pt2 (polar pt1 (* 0.25 pi) 700))
  (setq pt3 (polar pt1 (* 0.75 pi) 700))
  (setq pt4 (polar pt1 (* 1.25 pi) 700))
  (setq pt5 (polar pt1 (* 1.75 pi) 700))
  (setq ss2 (ssget "CP" (list pt2 pt3 pt4 pt5 pt2) (list (cons 0  "POINT"))))
  (setq obj3 (vlax-ename->vla-object (ssname ss2 0)))
  (setq pt (vlax-get obj3 'coordinates))
  (setq pt2 (vlax-curve-getclosestpointto obj2 pt))
  (vla-move  obj3 (vlax-3d-point pt) (vlax-3d-point pt2))
)
(prompt "\nSelect the text ")
(setq ss (ssget '((0 . "text"))))
(if (= (sslength ss) nil)
  (progn (alert "No objects selected\n will now exit ")(exit))
  (progn
  (repeat (setq x (sslength ss))
    (setq obj1 (vlax-ename->vla-object (ssname ss (setq x (1- x)))))
    (setq pttxt (vlax-get obj1 'InsertionPoint))
    (getline pttxt)
   (getpt pttxt)
  )
  )
)

(princ)
)

July 8, 2023

13 hours ago, BIGAL said:

Try this

(defun c:wow ( / ss ss2 pt pt2 pt3 pt4 pt5 obj1 obj2 obj3 pttxt getline getpt)

(defun getline (pt1 / pt2 pt3 pt4 pt5)
  (setq pt2 (polar pt1 (* 0.25 pi) 700))
  (setq pt3 (polar pt1 (* 0.75 pi) 700))
  (setq pt4 (polar pt1 (* 1.25 pi) 700))
  (setq pt5 (polar pt1 (* 1.75 pi) 700))
  (setq ss2 (ssget "F" (list pt2 pt3 pt4 pt5 pt2) (list (cons 0  "LINE"))))
  (setq obj2 (vlax-ename->vla-object (ssname ss2 0)))
  (setq pt2 (vlax-curve-getclosestpointto obj2 pttxt))
  (vla-move  obj1 (vlax-3d-point pttxt) (vlax-3d-point pt2))
)

(defun getpt (pt1 / pt2 pt3 pt4 pt5)
  (setq pt2 (polar pt1 (* 0.25 pi) 700))
  (setq pt3 (polar pt1 (* 0.75 pi) 700))
  (setq pt4 (polar pt1 (* 1.25 pi) 700))
  (setq pt5 (polar pt1 (* 1.75 pi) 700))
  (setq ss2 (ssget "CP" (list pt2 pt3 pt4 pt5 pt2) (list (cons 0  "POINT"))))
  (setq obj3 (vlax-ename->vla-object (ssname ss2 0)))
  (setq pt (vlax-get obj3 'coordinates))
  (setq pt2 (vlax-curve-getclosestpointto obj2 pt))
  (vla-move  obj3 (vlax-3d-point pt) (vlax-3d-point pt2))
)
(prompt "\nSelect the text ")
(setq ss (ssget '((0 . "text"))))
(if (= (sslength ss) nil)
  (progn (alert "No objects selected\n will now exit ")(exit))
  (progn
  (repeat (setq x (sslength ss))
    (setq obj1 (vlax-ename->vla-object (ssname ss (setq x (1- x)))))
    (setq pttxt (vlax-get obj1 'InsertionPoint))
    (getline pttxt)
   (getpt pttxt)
  )
  )
)

(princ)
)

it worked so good, but the problem is that this code moves the point to the lines. Isn't there anyway that the lines to be moved to the points ? as the points coordinates are important

July 8, 2023

Ok you should have made that clear at start, another problem is you have 2 lines not 1 so the end points need to be used of the lines. Can we erase the 2 lines and make 1 new one ? Just looked at image, so was not obvious you wanted point to control.

In terms of method its use Point instead of Text to do searching.

Edited July 8, 2023 by BIGAL

July 9, 2023

5 hours ago, BIGAL said:

Ok you should have made that clear at start, another problem is you have 2 lines not 1 so the end points need to be used of the lines. Can we erase the 2 lines and make 1 new one ? Just looked at image, so was not obvious you wanted point to control.

In terms of method its use Point instead of Text to do searching.

Sorry if i wasn't clear enough, my bad. I want the lines and texts to be moved to the points, for the lines actually they are two lines and unfortunately they should be 2 lines (as further i will export the 2 lines coordinates to excel)

July 9, 2023

"2 lines coordinates to excel" as they have a common pt is it not 3 points ?

You can be lucky just did this for someone.

; export line details to excel.
; By AlanH July 2023


(defun c:lexcel ( / putcell myxl ss row )

(defun putcell (cellname val1 / myrange)
(setq myRange (vlax-get-property  (vlax-get-property myxl "ActiveSheet") "Range" cellname))
(vlax-put-property myRange 'Value2 val1)
)

(or (setq myxl (vlax-get-object "Excel.Application"))
    (setq myxl (vlax-get-or-create-object "excel.Application"))
)
(vlax-invoke-method (vlax-get-property myXL 'WorkBooks) 'Add)
(vla-put-visible myXL :vlax-true)
(vlax-put-property myxl 'ScreenUpdating :vlax-true)
(vlax-put-property myXL 'DisplayAlerts :vlax-true)

(alert "\nPlease select all lines")
(setq ss (ssget (list (cons 0 "LINE"))))

(if (= ss nil)
(progn 
  (alert "no line objects selected \n will exit now ")
  (exit)
)
(progn
(setq row 1)
(putcell (strcat "A" (rtos row 2 0)) "Line No.")
(putcell (strcat "B" (rtos row 2 0)) "Handle")
(putcell (strcat "C" (rtos row 2 0)) "Startx")
(putcell (strcat "D" (rtos row 2 0)) "Starty")
(putcell (strcat "E" (rtos row 2 0)) "Endx")
(putcell (strcat "F" (rtos row 2 0)) "Endy")
(putcell (strcat "G" (rtos row 2 0)) "Length")

(setq row 2)
(repeat (setq k (sslength ss))
  (setq ent (entget (ssname ss (setq k (1- k)))))
  (setq start (cdr (assoc 10 ent)))
  (setq end (cdr (assoc 11 ent)))
  (setq hand (cdr (assoc 5 ent)))
  (setq dist (distance start end))
  (setq lay (cdr (assoc 8 ent)))
  (putcell (strcat "A" (rtos row 2 0)) (rtos (- row 1) 2 0))
  (putcell (strcat "B" (rtos row 2 0)) hand)
  (putcell (strcat "C" (rtos row 2 0)) (rtos (car start) 2 3))
  (putcell (strcat "D" (rtos row 2 0)) (rtos (cadr start) 2 3))
  (putcell (strcat "E" (rtos row 2 0)) (rtos (car end) 2 3))
  (putcell (strcat "F" (rtos row 2 0)) (rtos (cadr end) 2 3))
  (putcell (strcat "G" (rtos row 2 0)) (rtos dist 2 3))
  (setq row (1+ row))
)
)
)

(if (not (vlax-object-released-p myXL))(progn(vlax-release-object myXL)(setq myXL nil)))

(princ)
)
(c:lexcel)

; export line details to excel.
; By AlanH July 2023


(defun c:lexcel2 ( / putcell myxl ss row )
; put a value into a excel cell
(defun putcell (cellname val1 / myrange)
(setq myRange (vlax-get-property  (vlax-get-property myxl "ActiveSheet") "Range" cellname))
(vlax-put-property myRange 'Value2 val1)
)
; is excel open and open it anyway
(or (setq myxl (vlax-get-object "Excel.Application"))
    (setq myxl (vlax-get-or-create-object "excel.Application"))
)
(vlax-invoke-method (vlax-get-property myXL 'WorkBooks) 'Add) ; add a new workbook
(vla-put-visible myXL :vlax-true)
(vlax-put-property myxl 'ScreenUpdating :vlax-true)
(vlax-put-property myXL 'DisplayAlerts :vlax-true)

(alert "\nPlease select all lines")
(setq ss (ssget (list (cons 0 "LINE")))) ; select all lines through manual select yes can do (ssget "x" gets all

(if (= ss nil)
(progn 
  (alert "no line objects selected \n will exit now ")
  (exit) ; hard exit out of program
)
(progn
(setq row 1) ; row 1 in excel
(putcell (strcat "A" (rtos row 2 0)) "Line No.") ; put values into 1st row excel
(putcell (strcat "B" (rtos row 2 0)) "Handle") ; rtos real to string 2 engineering 3 decimal places.
(putcell (strcat "C" (rtos row 2 0)) "Startx")
(putcell (strcat "D" (rtos row 2 0)) "Starty")
(putcell (strcat "E" (rtos row 2 0)) "Endx")
(putcell (strcat "F" (rtos row 2 0)) "Endy")
(putcell (strcat "G" (rtos row 2 0)) "Length")

(setq row 2)
(repeat (setq k (sslength ss))
  (setq obj (vlax-ename->vla-object (ssname ss (setq k (- k 1))))) ; get items from selection set ussing ssname 
  (setq start (vlax-curve-getstartPoint obj)) ; start point
  (setq end (vlax-curve-getEndPoint obj))
  (setq hand (vlax-get obj 'Handle)) ; handle
  (setq dist (vlax-get obj 'Length))
  (setq lay (vlax-get obj 'layer))
  ; put values into excel
  ; can use a double loop so Col=1 =2 =3 etc rather than simple A B C
  ; (strcat "A" (rtos row 2 0)) = "A1"
  (putcell (strcat "A" (rtos row 2 0)) (rtos (- row 1) 2 0)) ; row is 2 but line is 1
  (putcell (strcat "B" (rtos row 2 0)) hand) 
  (putcell (strcat "C" (rtos row 2 0)) (rtos (car start) 2 3))
  (putcell (strcat "D" (rtos row 2 0)) (rtos (cadr start) 2 3))
  (putcell (strcat "E" (rtos row 2 0)) (rtos (car end) 2 3))
  (putcell (strcat "F" (rtos row 2 0)) (rtos (cadr end) 2 3))
  (putcell (strcat "G" (rtos row 2 0)) (rtos dist 2 3))
  (setq row (1+ row)) ; next row
)
)
)
; release xl object
(if (not (vlax-object-released-p myXL))(progn(vlax-release-object myXL)(setq myXL nil)))

(princ)
)
(c:lexcel2)

Edited July 9, 2023 by BIGAL

July 9, 2023

22 minutes ago, BIGAL said:

"2 lines coordinates to excel" as they have a common pt is it not 3 points ?

You can be lucky just did this for someone.

; export line details to excel.
; By AlanH July 2023


(defun c:lexcel ( / putcell myxl ss row )

(defun putcell (cellname val1 / myrange)
(setq myRange (vlax-get-property  (vlax-get-property myxl "ActiveSheet") "Range" cellname))
(vlax-put-property myRange 'Value2 val1)
)

(or (setq myxl (vlax-get-object "Excel.Application"))
    (setq myxl (vlax-get-or-create-object "excel.Application"))
)
(vlax-invoke-method (vlax-get-property myXL 'WorkBooks) 'Add)
(vla-put-visible myXL :vlax-true)
(vlax-put-property myxl 'ScreenUpdating :vlax-true)
(vlax-put-property myXL 'DisplayAlerts :vlax-true)

(alert "\nPlease select all lines")
(setq ss (ssget (list (cons 0 "LINE"))))

(if (= ss nil)
(progn 
  (alert "no line objects selected \n will exit now ")
  (exit)
)
(progn
(setq row 1)
(putcell (strcat "A" (rtos row 2 0)) "Line No.")
(putcell (strcat "B" (rtos row 2 0)) "Handle")
(putcell (strcat "C" (rtos row 2 0)) "Startx")
(putcell (strcat "D" (rtos row 2 0)) "Starty")
(putcell (strcat "E" (rtos row 2 0)) "Endx")
(putcell (strcat "F" (rtos row 2 0)) "Endy")
(putcell (strcat "G" (rtos row 2 0)) "Length")

(setq row 2)
(repeat (setq k (sslength ss))
  (setq ent (entget (ssname ss (setq k (1- k)))))
  (setq start (cdr (assoc 10 ent)))
  (setq end (cdr (assoc 11 ent)))
  (setq hand (cdr (assoc 5 ent)))
  (setq dist (distance start end))
  (setq lay (cdr (assoc 8 ent)))
  (putcell (strcat "A" (rtos row 2 0)) (rtos (- row 1) 2 0))
  (putcell (strcat "B" (rtos row 2 0)) hand)
  (putcell (strcat "C" (rtos row 2 0)) (rtos (car start) 2 3))
  (putcell (strcat "D" (rtos row 2 0)) (rtos (cadr start) 2 3))
  (putcell (strcat "E" (rtos row 2 0)) (rtos (car end) 2 3))
  (putcell (strcat "F" (rtos row 2 0)) (rtos (cadr end) 2 3))
  (putcell (strcat "G" (rtos row 2 0)) (rtos dist 2 3))
  (setq row (1+ row))
)
)
)

(if (not (vlax-object-released-p myXL))(progn(vlax-release-object myXL)(setq myXL nil)))

(princ)
)
(c:lexcel)

; export line details to excel.
; By AlanH July 2023


(defun c:lexcel2 ( / putcell myxl ss row )
; put a value into a excel cell
(defun putcell (cellname val1 / myrange)
(setq myRange (vlax-get-property  (vlax-get-property myxl "ActiveSheet") "Range" cellname))
(vlax-put-property myRange 'Value2 val1)
)
; is excel open and open it anyway
(or (setq myxl (vlax-get-object "Excel.Application"))
    (setq myxl (vlax-get-or-create-object "excel.Application"))
)
(vlax-invoke-method (vlax-get-property myXL 'WorkBooks) 'Add) ; add a new workbook
(vla-put-visible myXL :vlax-true)
(vlax-put-property myxl 'ScreenUpdating :vlax-true)
(vlax-put-property myXL 'DisplayAlerts :vlax-true)

(alert "\nPlease select all lines")
(setq ss (ssget (list (cons 0 "LINE")))) ; select all lines through manual select yes can do (ssget "x" gets all

(if (= ss nil)
(progn 
  (alert "no line objects selected \n will exit now ")
  (exit) ; hard exit out of program
)
(progn
(setq row 1) ; row 1 in excel
(putcell (strcat "A" (rtos row 2 0)) "Line No.") ; put values into 1st row excel
(putcell (strcat "B" (rtos row 2 0)) "Handle") ; rtos real to string 2 engineering 3 decimal places.
(putcell (strcat "C" (rtos row 2 0)) "Startx")
(putcell (strcat "D" (rtos row 2 0)) "Starty")
(putcell (strcat "E" (rtos row 2 0)) "Endx")
(putcell (strcat "F" (rtos row 2 0)) "Endy")
(putcell (strcat "G" (rtos row 2 0)) "Length")

(setq row 2)
(repeat (setq k (sslength ss))
  (setq obj (vlax-ename->vla-object (ssname ss (setq k (- k 1))))) ; get items from selection set ussing ssname 
  (setq start (vlax-curve-getstartPoint obj)) ; start point
  (setq end (vlax-curve-getEndPoint obj))
  (setq hand (vlax-get obj 'Handle)) ; handle
  (setq dist (vlax-get obj 'Length))
  (setq lay (vlax-get obj 'layer))
  ; put values into excel
  ; can use a double loop so Col=1 =2 =3 etc rather than simple A B C
  ; (strcat "A" (rtos row 2 0)) = "A1"
  (putcell (strcat "A" (rtos row 2 0)) (rtos (- row 1) 2 0)) ; row is 2 but line is 1
  (putcell (strcat "B" (rtos row 2 0)) hand) 
  (putcell (strcat "C" (rtos row 2 0)) (rtos (car start) 2 3))
  (putcell (strcat "D" (rtos row 2 0)) (rtos (cadr start) 2 3))
  (putcell (strcat "E" (rtos row 2 0)) (rtos (car end) 2 3))
  (putcell (strcat "F" (rtos row 2 0)) (rtos (cadr end) 2 3))
  (putcell (strcat "G" (rtos row 2 0)) (rtos dist 2 3))
  (setq row (1+ row)) ; next row
)
)
)
; release xl object
(if (not (vlax-object-released-p myXL))(progn(vlax-release-object myXL)(setq myXL nil)))

(princ)
)
(c:lexcel2)

Thank you so much, these lisp works perfect. You are really genius. I will export lines to excel but first i need them to be aligned or moved to the points

October 19

I've been making a few modifications to the program but I need to run the command on the objects twice now to change the text to the top centre bounding box of a block, circle or to the insert point of a point.

I've tried everything to fix it.

If someone could point me in the right direction to fix this, I'd greatly appreciate it.

;; 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 selection 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 users to choose different fuzz distance values.
;;  - Added selection of the modified objects after the code has finished. Handled in the error handler.
;;
;; Modified on 2024.10.19 by 3dwannab.
;;  - Modify the TEXT or MTEXT Objects
;;  - Change their rotation to 0
;;  - Change the justification to the bottom centre
;;  - Change the size to the same as the textsize variable
;;  - Change the MTEXTs with to 0
;;  - Align the TEXT objects to the top center of circles and blocks instead of the center of the circle or the insert point of the block
;;
;; Credit to Lee Mac for the original code
;;

(vl-load-com)

(defun c:Text_2_Point_Or_Block (/ *error* _getCircleTopCenter _getTopCenterBlk _mergeSelectionSets _textinsertion acDoc dcd di1 di2 dxf ent entname inc ins lst obj pnt regFuzz ss ssList tmp txt var_cmdecho) 

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

    (if ssList 
      (progn 
        (sssetfirst nil (_mergeSelectionSets ssList))
      )
    )
  )

  ;; Get any system variables here
  (setq var_cmdecho (getvar "cmdecho"))
  (setvar 'cmdecho 0)

  (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)
    )
  )

  ;; Written by chatgpt on 2024.10.19
  (defun _getCircleTopCenter (ent / center radius) 
    (if (and ent (eq (cdr (assoc 0 (entget ent))) "CIRCLE"))  ; Check if it's a circle
      (progn 
        ;; Get the center and radius of the circle
        (setq center (cdr (assoc 10 (entget ent)))) ; Center point (X, Y)
        (setq radius (cdr (assoc 40 (entget ent)))) ; Radius

        ;; Calculate the top-center of the bounding box
        (list 
          (car center) ; X remains the same
          (+ (cadr center) radius) ; Y is center Y + radius
          (if (cdr (assoc 30 (entget ent)))  ; Z-coordinate (if available)
            (cdr (assoc 30 (entget ent))) ; Get Z if available
            0.0
          )
        ) ; Default to 0 if not present
      )
      nil ; Return nil if the entity is not a circle
    )
  )

  ;; Written by chatgpt on 2024.10.19
  ;; Tested with dynamic blocks
  (defun _getTopCenterBlk (blk) 
    (if (and blk (eq (type blk) 'ENAME))  ; check if valid entity
      (progn 
        (setq extents (vla-getboundingbox 
                        (vlax-ename->vla-object blk)
                        'minpt
                        'maxpt
                      )
        ) ; get bounding box
        (setq minpt (vlax-safearray->list minpt))
        (setq maxpt (vlax-safearray->list maxpt))
        (list 
          (/ (+ (car minpt) (car maxpt)) 2) ; X (midpoint between min and max X)
          (cadr maxpt) ; Y (top Y)
          (/ (+ (caddr minpt) (caddr maxpt)) 2)
        )
      )
    )
  ) ; Z (midpoint between min and max Z)

  ;; 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 (ssList / Lst nSS) 
    (if (apply 'and (mapcar '(lambda (x) (= 'PICKSET (type x))) ssList)) 
      (progn 
        (setq nSS (ssadd))
        (mapcar 
          (function 
            (lambda (x / i) 
              (repeat (setq i (sslength x)) 
                (ssadd (ssname x (setq i (1- i))) nSS)
              )
            )
          )
          ssList
        )
      )
    )
    nSS
  )

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

  ;; Alert the user that the text size variable is small
  (if (> 5 (getvar "textsize")) 
    (alert (strcat "Textsize variable is small at " (rtos (getvar "textsize")) "!"))
  )

  ;; 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))

  ; (while T

  (progn 

    (princ "\nSelect point and text objects...\n")
    (if (setq ss (ssget "_:L" '((0 . "POINT,INSERT,CIRCLE,TEXT,MTEXT")))) 
      (progn 

        (repeat (setq inc (sslength ss)) 
          (setq ent (entget (setq entname (ssname ss (setq inc (1- inc))))))

          ;; If it's TEXT
          (if 
            (or 
              (eq (cdr (assoc 0 ent)) "TEXT")
              (eq (cdr (assoc 0 ent)) "MTEXT")
            )
            (setq txt (cons (cons (_textinsertion ent) ent) txt))
          )
          ;; If it's a POINT
          (if (eq (cdr (assoc 0 ent)) "POINT") 
            (setq lst (cons (cdr (assoc 10 ent)) lst))
          )
          ;; If it's a CIRCLE
          (if (eq (cdr (assoc 0 ent)) "CIRCLE") 
            (setq lst (cons (_getCircleTopCenter (cdr (car ent))) lst))
          )
          ;; If it's an INSERT
          (if (eq (cdr (assoc 0 ent)) "INSERT") 
            (setq lst (cons (_getTopCenterBlk (cdr (car ent))) lst))
          )

          ; (if (= 2 (sslength ss)) (setq regFuzz 5000)) ;; Set the reg fuzz value to large amount if only two objects are selected
        )
        (foreach ent txt 

          ;; Modify the TEXT or MTEXT Objects
          ;; Change their rotation to 0
          ;; Change the jusification to bottom centre
          ;; Change the size to the same as the textsize variable
          ;; Change the MTEXT's with to 0

          (setq obj (vlax-ename->vla-object (cdr (assoc -1 ent))))

          ;; If it's TEXT
          (if (eq (cdr (assoc 0 ent)) "TEXT") 
            (progn 
              (princ "\nIS TEXT\n")
              (vla-put-Height obj (getvar "textsize")) ;; Set text height to 0
              ;; Alignment Taken from DynamicTextAlign by LeeMac
              ;; 8 below is bottomcenter
              (if (eq AcAlignmentLeft (vla-get-Alignment obj)) 
                (progn 
                  (setq tmp (vla-get-InsertionPoint obj))
                  (vla-put-Alignment obj (+ 8 5))
                  (vla-put-TextAlignmentPoint obj tmp)
                )
                (vla-put-Alignment obj (+ 8 5))
              )
              (vla-put-Rotation obj 0) ;; Set text rotation to 0
            )
          )

          ;; If it's MTEXT
          (if (eq (cdr (assoc 0 ent)) "MTEXT") 
            (progn 
              (princ "\nIS MTEXT\n")
              (vla-put-Height obj (getvar "textsize")) ;; Set text height to 0
              (vla-put-Width obj 0) ;; Set text width to 0
              (vla-put-AttachmentPoint obj 8)
              (vla-put-Rotation obj 0) ;; Set text rotation to 0
            )
          )

          (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))
                )
                (princ "Text object too far away...")
              )
            ) ;; progn
          ) ;; if pnt
        ) ;; foreach
      ) ;; progn
    ) ;; if selection

    (setq ss nil)
    (setq ent nil)
    (setq ssList (cons ss ssList))
  ) ;; progn
  ; ) ;; while

  ;; Regen if the selection set ssList is valid
  (if ssList 
    (command-s "_.REGEN")
    (princ)
  )
  (*error* nil)
  (princ)
) ;; defun

                               
 (c:Text_2_Point_Or_Block) ;; Use for testing only

Edited October 19 by 3dwannab

October 19

I'm either stubborn or thick-witted or both.

Here's the working version. I just had to loop over the text objects first. I also added Lee Macs function to strip MTEXT of any formatting. Thanks, Lee for making this available!

;; 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 selection 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 users to choose different fuzz distance values.
;;  - Added selection of the modified objects after the code has finished. Handled in the error handler.
;;
;; Modified on 2024.10.19 by 3dwannab.
;;  - Modify the TEXT or MTEXT Objects
;;  - Change their rotation to 0
;;  - Change the justification to the bottom centre
;;  - Change the size to the same as the textsize variable
;;  - Change the MTEXTs with to 0
;;  - Align the TEXT objects to the top center of circles and blocks instead of the center of the circle or the insert point of the block
;;  - Took out the while loop as it was causing more issues that it was worth
;;
;; Credit to Lee Mac for the original code
;;

(vl-load-com)

(defun c:Text_2_Point_Or_Block (/ *error* _getCircleTopCenter _getTopCenterBlk _mergeSelectionSets _textinsertion acDoc dcd di1 di2 dxf ent entname inc ins lst obj pnt regExp regFuzz ss ssList tmp txt var_cmdecho) 

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

  ;; Get any system variables here
  (setq var_cmdecho (getvar "cmdecho"))
  (setvar 'cmdecho 0)

  (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)
    )
  )

  ;; Written by chatgpt on 2024.10.19
  (defun _getCircleTopCenter (ent / center radius) 
    (if (and ent (eq (cdr (assoc 0 (entget ent))) "CIRCLE"))  ; Check if it's a circle
      (progn 
        ;; Get the center and radius of the circle
        (setq center (cdr (assoc 10 (entget ent)))) ; Center point (X, Y)
        (setq radius (cdr (assoc 40 (entget ent)))) ; Radius

        ;; Calculate the top-center of the bounding box
        (list 
          (car center) ; X remains the same
          (+ (cadr center) radius) ; Y is center Y + radius
          (if (cdr (assoc 30 (entget ent)))  ; Z-coordinate (if available)
            (cdr (assoc 30 (entget ent))) ; Get Z if available
            0.0
          )
        ) ; Default to 0 if not present
      )
      nil ; Return nil if the entity is not a circle
    )
  )

  ;; Written by chatgpt on 2024.10.19
  ;; Tested with dynamic blocks
  (defun _getTopCenterBlk (blk) 
    (if (and blk (eq (type blk) 'ENAME))  ; check if valid entity
      (progn 
        (setq extents (vla-getboundingbox 
                        (vlax-ename->vla-object blk)
                        'minpt
                        'maxpt
                      )
        ) ; get bounding box
        (setq minpt (vlax-safearray->list minpt))
        (setq maxpt (vlax-safearray->list maxpt))
        (list 
          (/ (+ (car minpt) (car maxpt)) 2) ; X (midpoint between min and max X)
          (cadr maxpt) ; Y (top Y)
          (/ (+ (caddr minpt) (caddr maxpt)) 2)
        )
      )
    )
  ) ; Z (midpoint between min and max Z)

  ;; 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 (ssList / Lst nSS) 
    (if (apply 'and (mapcar '(lambda (x) (= 'PICKSET (type x))) ssList)) 
      (progn 
        (setq nSS (ssadd))
        (mapcar 
          (function 
            (lambda (x / i) 
              (repeat (setq i (sslength x)) 
                (ssadd (ssname x (setq i (1- i))) nSS)
              )
            )
          )
          ssList
        )
      )
    )
    nSS
  )

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

  ;; Alert the user that the text size variable is small
  (if (> 5 (getvar "textsize")) 
    (alert (strcat "Textsize variable is small at " (rtos (getvar "textsize")) "!"))
  )

  ;; 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))

  ; (while T

  (progn 

    (princ "\nSelect point and text objects...\n")
    (if (setq ss (ssget "_:L" '((0 . "POINT,INSERT,CIRCLE,TEXT,MTEXT")))) 
      (progn 

        ;; First change the test objects. Important that this is done first so the next steps are performed better
        (repeat (setq inc (sslength ss)) 
          (setq ent (entget (setq entname (ssname ss (setq inc (1- inc))))))

          (progn 
            ;; Modify the TEXT or MTEXT Objects
            ;; Change their rotation to 0
            ;; Change the jusification to bottom centre
            ;; Change the size to the same as the textsize variable
            ;; Change the MTEXT's with to 0

            (setq obj (vlax-ename->vla-object (cdr (assoc -1 ent))))

            ;; If it's TEXT
            (if (eq (cdr (assoc 0 ent)) "TEXT") 
              (progn 
                (vla-put-Rotation obj 0) ;; Set text rotation to 0
                (vla-put-Height obj (getvar "textsize")) ;; Set text height to 0
                ; Alignment Taken from DynamicTextAlign by LeeMac. 8 below is bottomcenter
                (if (eq AcAlignmentLeft (vla-get-Alignment obj)) 
                  (progn 
                    (setq tmp (vla-get-InsertionPoint obj))
                    (vla-put-Alignment obj (+ 8 5))
                    (vla-put-TextAlignmentPoint obj tmp)
                  )
                  (vla-put-Alignment obj (+ 8 5))
                )
              )
            )

            ;; If it's MTEXT
            (if (eq (cdr (assoc 0 ent)) "MTEXT") 
              (progn 
                (vla-put-Rotation obj 0) ;; Set text rotation to 0
                (vla-put-Height obj (getvar "textsize")) ;; Set text height to 0
                (vla-put-Width obj 0) ;; Set text width to 0
                (vla-put-AttachmentPoint obj 8)
                ;; Strip the formatting of the MTEXT with LeeMac function
                (setq regExp (vlax-get-or-create-object "VBScript.RegExp"))
                (LM:GetTrueContent RegExp (cdr (assoc -1 ent)) 'text 'mtext)
                (vla-put-TextString obj text)
              )
            )
          )
        )

        ;; Another repeat to loop over the entities and retrieve the information required to link the two together, ie. the top center of blocks, circles and the insert point of a point object.
        (repeat (setq inc (sslength ss)) 
          (setq ent (entget (setq entname (ssname ss (setq inc (1- inc))))))

          (progn 

            ;; If it's TEXT
            (if 
              (or 
                (eq (cdr (assoc 0 ent)) "TEXT")
                (eq (cdr (assoc 0 ent)) "MTEXT")
              )
              (setq txt (cons (cons (_textinsertion ent) ent) txt))
            )
            ;; If it's a POINT
            (if (eq (cdr (assoc 0 ent)) "POINT") 
              (setq lst (cons (cdr (assoc 10 ent)) lst))
            )
            ;; If it's a CIRCLE
            (if (eq (cdr (assoc 0 ent)) "CIRCLE") 
              (setq lst (cons (_getCircleTopCenter (cdr (car ent))) lst))
            )
            ;; If it's an INSERT
            (if (eq (cdr (assoc 0 ent)) "INSERT") 
              (setq lst (cons (_getTopCenterBlk (cdr (car ent))) lst))
            )

            ; (if (= 2 (sslength ss)) (setq regFuzz 5000)) ;; Set the reg fuzz value to large amount if only two objects are selected
          )
        )
        (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))
                )
                (princ "Text object too far away...")
              )
            ) ;; progn
          ) ;; if pnt
        ) ;; foreach

        (setq ss nil)
        (setq ent nil)
        (setq di1 nil)
      ) ;; progn
    ) ;; if selection

    (setq ssList (cons ss ssList))
  ) ;; progn
  ; ) ;; while

  ;; Regen if the selection set ssList is valid
  (if ssList 
    (progn 
      (sssetfirst nil (_mergeSelectionSets ssList))
      (command "_.REGEN")
    )
  )

  (*error* nil)
  (princ)
) ;; defun

;;------------------=={ Get True Content }==------------------;;
;;                                                            ;;
;;  Returns the unformatted string associated with the        ;;
;;  supplied entity, in formats compatible with Text & MText  ;;
;;  objects.                                                  ;;
;;                                                            ;;
;;  The arguments *dtextstring & *mtextstring should be       ;;
;;  supplied with quoted symbols (other than those symbols    ;;
;;  used by the arguments themselves). The unformatted        ;;
;;  strings suitable for Text & MText objects will henceforth ;;
;;  be bound to the supplied symbol arguments respectively.   ;;
;;                                                            ;;
;;  Note that it is the caller's responsibility to create and ;;
;;  release the RegularExpressions (RegExp) object. This      ;;
;;  object may be created using the                           ;;
;;  Programmatic Identifier: "VBScript.RegExp".               ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2010 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  RegExp       - RegularExpressions (RegExp) Object         ;;
;;  entity       - Ename whose text content is to be returned ;;
;;  *dtextstring - (output) Unformatted string compatible     ;;
;;                 with Text entities                         ;;
;;  *mtextstring - (output) Unformatted string compatible     ;;
;;                 with MText entities                        ;;
;;------------------------------------------------------------;;
;;  Returns:    This function always returns nil              ;;
;;------------------------------------------------------------;;

(defun LM:GetTrueContent (RegExp entity *dtextstring *mtextstring / _Replace _AllowsFormatting _GetTextString) 

  (defun _Replace (new old string) 
    (vlax-put-property RegExp 'pattern old)
    (vlax-invoke RegExp 'replace string new)
  )

  (defun _AllowsFormatting (entity / object) 
    (or (wcmatch (cdr (assoc 0 (entget entity))) "MTEXT,MULTILEADER") 
        (and 
          (eq "ATTRIB" (cdr (assoc 0 (entget entity))))
          (vlax-property-available-p (setq object (vlax-ename->vla-object entity)) 'MTextAttribute)
          (eq :vlax-true (vla-get-MTextAttribute object))
        )
    )
  )

  (defun _GetTextString (entity) 
    ((lambda (entity / _type elist) 
       (cond 
         ((wcmatch (setq _type (cdr (assoc 0 (setq elist (entget entity))))) "TEXT,*DIMENSION")

          (cdr (assoc 1 (reverse elist)))
         )
         ((eq "MULTILEADER" _type)

          (cdr (assoc 304 elist))
         )
         ((wcmatch _type "ATTRIB,MTEXT")

          ((lambda (string) 
             (mapcar 
               (function 
                 (lambda (pair) 
                   (if (member (car pair) '(1 3)) 
                     (setq string (strcat string (cdr pair)))
                   )
                 )
               )
               elist
             )
             string
           ) 
            ""
          )
         )
       )
     ) 
      (if (eq 'VLA-OBJECT (type entity)) 
        (vlax-vla-object->ename entity)
        entity
      )
    )
  )

  ((lambda (string) 
     (if string 
       (progn 
         (mapcar 
           (function 
             (lambda (x) (vlax-put-property RegExp (car x) (cdr x)))
           )
           (list (cons 'global actrue) (cons 'ignorecase acfalse) (cons 'multiline actrue))
         )
         (if (_AllowsFormatting entity) 
           (mapcar 
             (function 
               (lambda (x) (setq string (_Replace (car x) (cdr x) string)))
             )
             '(("Ð" . "\\\\\\\\")
               (" " . "\\\\P|\\n|\\t")
               ("$1" . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]")
               ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
               ("$1$2" . "\\\\(\\\\S)|[\\\\](})|}")
               ("$1" . "[\\\\]({)|{")
              )
           )
           (setq string (_Replace "" "%%[OoUu]" (_Replace "Ð" "\\\\" string)))
         )
         (set *mtextstring (_Replace "\\\\" "Ð" (_Replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" string)))
         (set *dtextstring (_Replace "\\" "Ð" string))
       )
     )
   ) 
    (_GetTextString entity)
  )
  nil
)

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

Sign In

Moving Text Block to adjacent point

Recommended Posts

asdfgh

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

Lee Mac

Lee Mac

GTVic

Posted Images

BIGAL

BIGAL

asdfgh

BIGAL

asdfgh

BIGAL

asdfgh

3dwannab

3dwannab

Join the conversation

Lee Mac

Lee Mac

GTVic

Tutorials

Forums

Activity