Mass move block to nearest polyline

[eoconnor95662]

As noted in title I would like a LISP command to mass move blocks to nearest polyline. I've researched and found commands like lee mac's move block to polyline but it doesn't work in mass. Any feedback or existing AutoCAD functions would be much appreciated.

[dlanorh]

Hmm, it works for me in 2012. But it is tested where I know how the drawing is set up. I have tweaked the routine as I missed declaring some of the variables as local, and also didn't load the VL extensions.

It was only a concept, so I have included my test drawing. The centreline is the white angled line and the lines to move are all the green lines which you can select all together. This only works on LINE entities not polylines at present, but is adaptable, and only moves the lines in along the start point end point axis.

Update Lisp

(defun c:m2l2 ( / ent s1 e1 ss cnt lent el s2 e2 mpt ipt)

(vl-load-com)
  
  (setq ent (car (entsel "\nSelect Centreline : "))
        s1 (cdr (assoc 10 (entget ent)))
        e1 (cdr (assoc 11 (entget ent)))
  );end_setq

  (prompt "\nSelect Lines to Move : ")
  (setq ss (ssget ":L" '((0 . "LINE"))))

  (cond (ss
	  (if (ssmemb ent ss) (ssdel ent ss))
          (repeat (setq cnt (sslength ss))
            (setq el (entget (setq lent (ssname ss (setq cnt (1- cnt)))))
                  mpt (mapcar '(lambda (x y) (/ (+ x y) 2.0)) (setq s2 (cdr (assoc 10 el))) (setq e2 (cdr (assoc 11 el))))
                  ipt (inters s1 e1 s2 e2 nil)
            );end_setq
            (cond (ipt (vlax-invoke (vlax-ename->vla-object lent) 'move mpt ipt)))
          );end_repeat
        )
  );end_cond
  (princ)
);end_defun

[mbaxterB9TKM]

I am an idiot! I had my centerline as a polyline instead of just a line. I realized my mistake when comparing my drawing to yours. Now it works perfectly!! Thank you so much for your help!

[dlanorh]

@mbaxterB9TKM 

This should allow a Line or single segment Polyline for the centreline. If you want to expand to accept single segment polylines in the "Lines" to move, let me know.

(defun c:m2l2 ( / ent s1 e1 ss cnt lent el s2 e2 mpt ipt)

(vl-load-com)
  (while (not ent)
    (setq ent (car (entsel "\nSelect Centreline : ")))
    (cond ( (or (= (cdr (assoc 90 (entget ent))) 2)
                (not (cdr (assoc 90 (entget ent))))
            )
            (setq s1 (vlax-curve-getstartpoint ent)
                  e1 (vlax-curve-getendpoint ent)
            )
          )
          (t (alert "Not a LINE or single segment Polyline") (setq ent nil))
    );end_cond
  );end_while

  (prompt "\nSelect Lines to Move : ")
  (setq ss (ssget ":L" '((0 . "LINE"))))

  (cond (ss
	  (if (ssmemb ent ss) (ssdel ent ss))
          (repeat (setq cnt (sslength ss))
            (setq el (entget (setq lent (ssname ss (setq cnt (1- cnt)))))
                  mpt (mapcar '(lambda (x y) (/ (+ x y) 2.0)) (setq s2 (cdr (assoc 10 el))) (setq e2 (cdr (assoc 11 el))))
                  ipt (inters s1 e1 s2 e2 nil)
            );end_setq
            (cond (ipt (vlax-invoke (vlax-ename->vla-object lent) 'move mpt ipt)))
          );end_repeat
        )
  );end_cond
  (princ)
);end_defun

[mbaxterB9TKM]

I didn't want to bug you again when you have already helped me so much, but if you could expand the lisp to accept single segment polylines in the "Lines" to move that would be amazing!

Thank you!

[dlanorh]

@mbaxterB9TKM 

This should work.

You can select a Line or single segment LWPolyline as the centreline. You will get an alert if it isn't either and you can select again.

For the Move lines, you will get an alert telling you how many move lines were not Lines or single segment Polylines. These lines will not be moved.

I have attached the lisp to make it easier than copying and pasting. Ignore the 3 on the end of the lisp. This is just a revision number for my storage, the M2L2 to run still holds.

[mbaxterB9TKM]

You are a GENIUS! It works perfectly! I am so excited right now! Thank you! Thank you! Thank you!

[Anonymous]

Hello,

This is a great lisp, is there a way to move the block along the Z axis of a 3D polyline?

Thanks

[dlanorh]

Which lisp?

A better explanation of what you want to achieve is needed. You want to move block to a 3dpolyline, or the blocks are on a 3d polyline but not at the required level?

[jtm2020hyo]

maybe this help:

https://www.theswamp.org/index.php?topic=55727.0

    (defun c:stretch-move-blks-lws ( / ssblks sslws ch dpl spl lwx dm d np npl k lwxn pl p )
      (while
        (or
          (prompt "\nSelect block INSERT references on unlocked layer(s)...")
          (not (setq ssblks (ssget "_:L" '((0 . "INSERT")))))
        )
        (prompt "\nEmpty sel. set...")
      )
      (while
        (or
          (prompt "\nSelect LWPOLYLINES on unlocked layer(s)...")
          (not (setq sslws (ssget "_:L" '((0 . "LWPOLYLINE")))))
        )
        (prompt "\nEmpty sel. set...")
      )
      (initget 1 "Stretch Move")
      (setq ch (getkword "\nStretch LWPOLYLINE vertices to nearest BLOCKS or move BLOCKS to nearest LWPOLYLINE vertices [Stretch/Move] : "))
      (if (= ch "Stretch")
        (progn
          (setq dpl (apply 'append (mapcar '(lambda ( x ) (mapcar 'cdr (vl-remove-if '(lambda ( y ) (/= (car y) 10)) x))) (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssblks)))))))
          (foreach lw (vl-remove-if 'listp (mapcar 'cadr (ssnamex sslws)))
            (setq spl (mapcar '(lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 lwx))) lw 0)) (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (setq lwx (entget lw))))))
            (foreach p spl
              (setq dm 1e+99)
              (foreach pp dpl
                (if (< (setq d (distance p pp)) dm)
                  (setq dm d np pp)
                )
              )
              (setq npl (cons np npl))
            )
            (setq npl (reverse npl))
            (setq npl (mapcar '(lambda ( x ) (trans x 0 lw)) npl))
            (setq k -1)
            (foreach x lwx
              (if (= (car x) 10)
                (setq lwxn (append lwxn (list (cons 10 (nth (setq k (1+ k)) npl)))))
                (setq lwxn (append lwxn (list x)))
              )
            )
            (entupd (cdr (assoc -1 (entmod lwxn))))
            (setq npl nil lwxn nil)
          )
        )
        (progn
          (foreach lw (vl-remove-if 'listp (mapcar 'cadr (ssnamex sslws)))
            (setq pl (mapcar '(lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 lwx))) lw 0)) (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (setq lwx (entget lw))))))
            (setq dpl (append pl dpl))
          )
          (foreach blk (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssblks)))
            (setq dm 1e+99)
            (foreach pp dpl
              (if (< (setq d (distance (if (null p) (setq p (cdr (assoc 10 (entget blk)))) p) pp)) dm)
                (setq dm d np pp)
              )
            )
            (setq p nil)
            (entupd (cdr (assoc -1 (entmod (subst (cons 10 np) (assoc 10 (entget blk)) (entget blk))))))
          )
        )
      )
      (princ)
    )
     

[Anonymous]

The routine is the one below:

(defun c:m2l ( / l_ss b_ss b_cnt b_ent i_pt min_dist m_pt l_cnt l_ent c_pt md m_ang)

  (prompt "\nSelect Lines : ")
  (setq l_ss (ssget "_X" '((0 . "ARC,CIRCLE,ELLIPSE,LINE,LWPOLYLINE,POLYLINE,SPLINE") (8 . "SPPC-E-EL"))))

  (prompt "\nSelect Blocks : ")
  (setq b_ss (ssget '((0 . "INSERT") (2 . "552-2,551-1,552-0-CO"))))  
 
  (repeat (setq b_cnt (sslength b_ss))
    (setq b_ent (ssname b_ss (setq b_cnt (1- b_cnt)))
          i_pt (cdr (assoc 10 (entget b_ent)))
          min_dist 1000000
          m_pt nil
    )
    (repeat (setq l_cnt (sslength l_ss))
      (setq l_ent (ssname l_ss (setq l_cnt (1- l_cnt)))
            c_pt (vlax-curve-getclosestpointto l_ent i_pt)
      )
      (cond ( (< (setq md (distance i_pt c_pt)) min_dist)
              (setq min_dist md
                    m_pt c_pt
              )
            )
      )
    )
    (setq m_ang (angle i_pt m_pt)
          m_pt (polar i_pt m_ang (- min_dist 5.0));;5.0 = radius of circle in block
    )
    (vla-move (vlax-ename->vla-object b_ent) (vlax-3d-point i_pt) (vlax-3d-point m_pt))
  )
  (princ)
)

[dlanorh]

The lisp was specifically designed to move certain blocks (by name) to certain lines (automatically selected by layer) so that the edge of the block (a circle) touched the polyline.

If I strip out the superflous code and change it to move the insertion point of the block (s) to the nearest polyline, you are left with

(defun c:m2l ( / l_ss b_ss b_cnt b_ent i_pt min_dist m_pt l_cnt l_ent c_pt md m_ang)

  (prompt "\nSelect Lines : ")
  (setq l_ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,LINE,LWPOLYLINE,POLYLINE,SPLINE"))))

  (prompt "\nSelect Blocks : ")
  (setq b_ss (ssget '((0 . "INSERT"))))
 
  (repeat (setq b_cnt (sslength b_ss))
    (setq b_ent (ssname b_ss (setq b_cnt (1- b_cnt)))
          i_pt (cdr (assoc 10 (entget b_ent)))
          min_dist 1000000
          m_pt nil
    )
    (repeat (setq l_cnt (sslength l_ss))
      (setq l_ent (ssname l_ss (setq l_cnt (1- l_cnt)))
            c_pt (vlax-curve-getclosestpointtoprojection l_ent i_pt (cdr (assoc 210 (entget l_ent))))
      )
      (cond ( (< (setq md (distance i_pt c_pt)) min_dist)
              (setq min_dist md
                    m_pt c_pt
              )
            )
      )
    )
    (setq m_ang (angle i_pt m_pt)
          m_pt (polar i_pt m_ang min_dist);;5.0 = radius of circle in block
    )
    (vla-move (vlax-ename->vla-object b_ent) (vlax-3d-point i_pt) (vlax-3d-point m_pt))
  )
  (princ)
)

You will need to select the all the 3dpolylines needed, then the all the blocks to move and this should do what you want. It works correctly in my brief testing.

[Anonymous]

Great code as usual. I am not very familiar with VBA - is it possible to snap text to block using this same architecture? The objective here is to move a block next to an object, at the same time moving the related text (layer) to the new block location.

[Kent1Cooper]

---

@Anonymous wrote:

Great code as usual. I am not very familiar with VBA - is it possible to snap text to block using this same architecture? The objective here is to move a block next to an object, at the same time moving the related text (layer) to the new block location.

---

[It's not VBA, but AutoLisp.]  To which great code are you referring?

Since there are two Text objects near each Block in your sample drawing, where should they go?  If with their insertion points moved to the Block's insertion point, and with the Block's insertion point taken to the nearest object, you'll get this kind of thing:

which doesn't seem likely to be what you want.

If not that, what criteria do you have for positioning things?

[Anonymous]

I was hoping for a simple modification on the below AutoLisp code. With emphasis on the 5.0 offset (commented), I would want a that triangle to snap to the line, offset by a distance so it usually would not touch the line.

The text would be adjacent to the block, and the two lines should not be stacked, I was thinking that they could be consecutive lines, as if an MTEXT.

(defun c:m2l ( / l_ss b_ss b_cnt b_ent i_pt min_dist m_pt l_cnt l_ent c_pt md m_ang)

  (prompt "\nSelect Lines : ")
  (setq l_ss (ssget "_X" '((0 . "ARC,CIRCLE,ELLIPSE,LINE,LWPOLYLINE,POLYLINE,SPLINE") (8 . "SPPC-E-EL"))))

  (prompt "\nSelect Blocks : ")
  (setq b_ss (ssget '((0 . "INSERT") (2 . "552-2,551-1,552-0-CO"))))  
 
  (repeat (setq b_cnt (sslength b_ss))
    (setq b_ent (ssname b_ss (setq b_cnt (1- b_cnt)))
          i_pt (cdr (assoc 10 (entget b_ent)))
          min_dist 1000000
          m_pt nil
    )
    (repeat (setq l_cnt (sslength l_ss))
      (setq l_ent (ssname l_ss (setq l_cnt (1- l_cnt)))
            c_pt (vlax-curve-getclosestpointto l_ent i_pt)
      )
      (cond ( (< (setq md (distance i_pt c_pt)) min_dist)
              (setq min_dist md
                    m_pt c_pt
              )
            )
      )
    )
    (setq m_ang (angle i_pt m_pt)
          m_pt (polar i_pt m_ang (- min_dist 5.0));;5.0 = radius of circle in block
    )
    (vla-move (vlax-ename->vla-object b_ent) (vlax-3d-point i_pt) (vlax-3d-point m_pt))
  )
  (princ)
)

[Kent1Cooper]

First of all, can you redefine the Block so that its insertion point is in the middle?  As it is, if the insertion point is positioned for appropriate distance, the relationship of the drawn Block parts to the "path" object is going vary greatly depending on the direction that object runs.

And define "adjacent to" for the Text relative to the Block.  I assume, for example, that if the "path" object is running something like in my previous image, the Text should be to the right of the Block.  But there must be situations where it should be to the left, and maybe above or below.

[Anonymous]

I wish! that would make this triangle much easier to maneuver, the cheat here would be snap the block (new sample) to another block and skip the whole line alignment issue. If you could make something like that it would solve the problem with spacing. 

The text can be solved in a similar manner if X,Y maneuvers are available; the triangle and the two text lines need to be offset from each other by a character length of 1+. The main goal here is to make all three objects function so a fence window can easily select.

Alignment to the line is secondary to grouping, I was tempted to make a new post.

[Anonymous]

[tvasimpl]

@dlanorh moving back to the original post, is there a way to move only blocks within a certain radius from the target lines/polylines etc. 

What I mean by that is that I do not want to move blocks from very far away to the closest line

Thanks in advance

[Anonymous]

(defun c:m2l ( / l_ss b_ss b_cnt b_ent i_pt min_dist m_pt l_cnt l_ent c_pt md m_ang)

  (prompt "\nSelect Lines : ")
  (setq l_ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,LINE,LWPOLYLINE,POLYLINE,SPLINE"))))

  (prompt "\nSelect Blocks : ")
  (setq b_ss (ssget '((0 . "INSERT"))))
 
  (repeat (setq b_cnt (sslength b_ss))
    (setq b_ent (ssname b_ss (setq b_cnt (1- b_cnt)))
          i_pt (cdr (assoc 10 (entget b_ent)))
          min_dist 1000000
          m_pt nil
    )
    (repeat (setq l_cnt (sslength l_ss))
      (setq l_ent (ssname l_ss (setq l_cnt (1- l_cnt)))
            c_pt (vlax-curve-getclosestpointtoprojection l_ent i_pt (cdr (assoc 210 (entget l_ent))))
      )
      (cond ( (< (setq md (distance i_pt c_pt)) min_dist)
              (setq min_dist md
                    m_pt c_pt
              )
            )
      )
    )
    (setq m_ang (angle i_pt m_pt)
          m_pt (polar i_pt m_ang min_dist);;5.0 = radius of circle in block
    )
    (vla-move (vlax-ename->vla-object b_ent) (vlax-3d-point i_pt) (vlax-3d-point m_pt))
  )
  (princ)
)

If you change the line

 min_dist 1000000

to 

min dist 100

it will only grab blocks within 100u of the last point on the line vla located.

The number value limits the distance the blocks move from the reference.

[7Archaeologist84BFCP]

Could anyone possibly change @dlanorh 's script to change block's layer to that of a nearest polyline (nearest from blocks insertion point)? It would save me massive amounts of work.