Move blocks to nearest detected curve

[Anonymous]

I am looking for a LISP program that will allow me to window/intersection select multiple blocks and move them horizontally to the nearest intersection with a line/p-line/spline in a selected direction. I also need the program to automatically detect the nearest curve in the selected direction. I do not want to have to select a curve manually.

The command would have the following prompts:

1. Select blocks

> I select the blocks with a window or intersect then hit the space bar

2. Prompt direction

> I select a direction

> Blocks are moved to the nearest line/polyline/spline in the selected direction

I have included screenshots showing the desired steps.

[dlanorh]

This has been answered before, but you have a new wrinkle.

Try this.

(defun rh:ss2lst( ss opt / cnt lst)
  (cond ( (and ss (= (type ss) 'PICKSET))
          (repeat (setq cnt (sslength ss)) (setq lst (cons (ssname ss (setq cnt (1- cnt))) lst)))
          (if opt (setq lst (mapcar 'vlax-ename->vla-object lst)))
        )
  );end_cond
  lst
);end_defun

(vl-load-com)

(defun c:mbo ( / *error* c_doc c_spc mv_lst ss llst v cnt n_pt blk i_pt n_obj xlst lst)

  (defun *error* ( msg )
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
    (princ)
  );_end_*error*_defun

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_spc (vlax-get-property c_doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
        mv_lst (list '(0.0 1.0 0.0) '(0.0 -1.0 0.0) '(-1.0 0.0 0.0) '(1.0 0.0 0.0))
        ss (ssget "_X" '((0 . "LINE,LWPOLYLINE,POLYLINE,SPLINE")))
        llst (rh:ss2lst ss t)
        ss nil
  );end_setq
  
  (cond (llst
          (prompt "\nSelect Blocks to Move : ")
          (setq ss (ssget "_:L" '((0 . "INSERT"))))
          (cond (ss
                  (initget 1 "Up Down Left Right")
                  (setq v (cond ( (getkword "\nSelect Move Direction : [Up/Down/Left/Right] <Up> ")) ("Up")))
                  (setq v (nth (vl-position v (list "Up" "Down" "Left" "Right")) mv_lst))
                  
                  (repeat (setq cnt (sslength ss))
                    (setq n_pt nil xlst nil lst nil
                          blk (ssname ss (setq cnt (1- cnt)))
                          i_pt (cdr (assoc 10 (entget blk)))
                          n_obj (vlax-invoke c_spc 'addray i_pt (mapcar '+ i_pt v))
                    );end_setq
                    (foreach x llst (setq xlst (cons (vlax-invoke n_obj 'intersectwith x acextendnone) xlst)))
                    (vla-delete n_obj)
                    (mapcar '(lambda (x) (setq lst (cons (list (distance i_pt x) x) lst))) (vl-remove-if '(lambda (x) (not x)) xlst))
                    (setq n_pt (car (mapcar 'cadr (vl-sort lst '(lambda (x y) (< (car x) (car y)))))))
                    (if n_pt (vlax-invoke (vlax-ename->vla-object blk) 'move i_pt n_pt))
                  );end_repeat
                )
                (t (alert "NO Blocks selected"))
          );end_cond
        )  
        (t (alert "NO Lines selected"))
  );end_cond
  (princ)
);end_defun

[Anonymous]

Thank you, this is is just what I am looking for!

I was wondering if you could add a conditional so the blocks ignore curves on locked layers. I would also like to handle an edge case: if a block is already located on a line/curve then blocks move to the next curve. I have attached photos of the edge case. Thank you again.

[dlanorh]

Is this to be done automatically (test if blk is on a line) or as an option (additional input asking this to be taken into account, Yes No answer, if Yes impliment it, if No as normal)?

[Anonymous]

Yes, automatically

[dlanorh · Accepted solution]

OK. Tested and works in my version (2012).

(defun rh:ss2lst( ss opt / cnt ent elst lyr lst)
  (cond ( (and ss (= (type ss) 'PICKSET))
          (repeat (setq cnt (sslength ss))
            (setq ent (ssname ss (setq cnt (1- cnt)))
                  elst (entget ent)
                  lyr (tblsearch "layer" (cdr (assoc 8 elst)))
            );end_setq
            (if (/= 4 (logand 4 (cdr (assoc 70 lyr)))) (setq lst (cons ent lst)))
          );end_repeat
          (if opt (setq lst (mapcar 'vlax-ename->vla-object lst)))
        )
  );end_cond
  lst
);end_defun

(vl-load-com)

(defun c:mbo ( / *error* c_doc c_spc mv_lst ss llst v cnt n_pt blk i_pt n_obj xlst lst)

  (defun *error* ( msg )
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
    (princ)
  );_end_*error*_defun

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_spc (vlax-get-property c_doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
        mv_lst (list '(0.0 1.0 0.0) '(0.0 -1.0 0.0) '(-1.0 0.0 0.0) '(1.0 0.0 0.0))
        ss (ssget "_X" '((0 . "LINE,LWPOLYLINE,POLYLINE,SPLINE")))
        llst (rh:ss2lst ss t)
        ss nil
  );end_setq
  
  (cond (llst
          (prompt "\nSelect Blocks to Move : ")
          (setq ss (ssget "_:L" '((0 . "INSERT"))))
          (cond (ss
                  (initget 1 "Up Down Left Right")
                  (setq v (cond ( (getkword "\nSelect Move Direction : [Up/Down/Left/Right] <Up> ")) ("Up")))
                  (setq v (nth (vl-position v (list "Up" "Down" "Left" "Right")) mv_lst))
                  
                  (repeat (setq cnt (sslength ss))
                    (setq n_pt nil xlst nil lst nil
                          blk (ssname ss (setq cnt (1- cnt)))
                          i_pt (cdr (assoc 10 (entget blk)))
                          n_obj (vlax-invoke c_spc 'addray i_pt (mapcar '+ i_pt v))
                    );end_setq
                    (foreach x llst (setq xlst (cons (vlax-invoke n_obj 'intersectwith x acextendnone) xlst)))
                    (vla-delete n_obj)
                    (mapcar '(lambda (x) (setq lst (cons (list (distance i_pt x) x) lst))) (vl-remove-if '(lambda (x) (not x)) xlst))
                    ;;EDGE CASE HERE
                    (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y)))))
                    (if (zerop (caar lst))
                      (setq n_pt (cadr (mapcar 'cadr lst)))
                      (setq n_pt (car (mapcar 'cadr lst)))
                    );end_if
                    (if n_pt (vlax-invoke (vlax-ename->vla-object blk) 'move i_pt n_pt))
                  );end_repeat
                )
                (t (alert "NO Blocks selected"))
          );end_cond
        )  
        (t (alert "NO Lines selected"))
  );end_cond
  (princ)
);end_defun

[Anonymous]

This is perfect, thank you very much.