STRETCH_DUCT_LINE_TO_INTERSECT_v1_02

Command: SDTI

This function stretches selected end of autocad meps duct to intersection point with another duct. Objects have to be coplanar. Works also with pipes, cabeltrays and standard lines.
Sometimes autocad MEP has problems with connectiong objects. Instead the user can stretch one pipe to the intersection point and then start drawing from that point.

 

Code:

;;; =================================================
;;;        STRETCH_DUCT_TO_INTERSECT_v1_02.LSP
;;;
;;;        Written by Andrzej Kalinowski,     www.autolisps.blogspot.com
;;;        v1.00 - 15.10.2016
;;;        v1.02 - 18.04.2019 - updated error function
;;;
;;;        Command: SDTI
;;;            This function stretches selected end of autocad meps duct to intersection point with another duct.
;;;            Objects have to be coplanar. Works also with pipes, cabeltrays and standard lines.
;;;
;;; =================================================
(vl-load-com)
(defun C:SDTI (/ obj1 obj2 pt1 pt2 pt3 pt4  intPt )
    (setq doc1 (vla-get-activedocument (vlax-get-acad-object)))
    (vla-startundomark doc1)
    ;-----------------------------------------
    ;error section
    ;-----------------------------------------
    (defun *error* (msg) (princ "error: ") (princ msg) (princ) )
    (defun errtrap1 (errormsg1)
        (setq *error* temperr)
        (if (not command-s);checks if command-s is recognised to work with older autocad versions. Prevents error:  "_cannot_invoke_from_err_solution"
            (progn
                (command "_UCS" "_NA" "_R" "old_ucs1"); restoring UCSr
                (command "_UCS" "_NA" "_D" "old_ucs1");deleting ucs name. "command" doesnt work within error trap. You have to use "vl-cmdf"
            );progn
            (progn
                (command-s "_UCS" "_NA" "_R" "old_ucs1"); restoring UCSr
                (command-s "_UCS" "_NA" "_D" "old_ucs1");deleting ucs name. "command" doesnt work within error trap. You have to use "vl-cmdf"
            );progn
        );if
        (vla-endundomark doc1)
        (princ "\n---------------------error---------------------")
        (if (and errormsg1 (not (wcmatch (strcase errormsg1) "*BREAK*,*CANCEL*,*QUIT*") ) )
            (prompt (strcat "\nError: " errormsg1) );then
        );if
        (princ) 
    );defun err
    ;-----------------------------------------
    ;setting variables
    ;-----------------------------------------
    (setq
        temperr *error* 
        *error* errtrap1 
    );setq
    (command "_UCS" "_NA" "_D" "old_ucs1")
    (command "_UCS" "_NA" "_S" "old_ucs1");naming current UCS
    (command "_ucs" "w")
    ;-----------------------------------------
    (setq obj1 (vlax-ename->vla-object (car (entsel "\nSelect duct1/pipe1: \n") ) )
          obj2 (vlax-ename->vla-object (car (entsel "\nSelect duct2/pipe2: \n") ) )
    );setq
    (if (and
            (vlax-property-available-p obj1 "EndPoint")
            (vlax-property-available-p obj2 "EndPoint")
        );and
        (progn
            (setq pt1 (vlax-get obj1 'StartPoint)
                  pt2 (vlax-get obj1 'EndPoint)
                  pt3 (vlax-get obj2 'StartPoint)
                  pt4 (vlax-get obj2 'EndPoint)
                  intPt (inters pt1 pt2 pt3 pt4 nil)
            ); setq
            (if (= intPt nil)
                (alert "No intersection point found...")
                (progn
                    (if (> (distance pt1 intPt) (distance pt2 intPt) )
                        (vla-put-endpoint obj1 (vlax-3D-point intPt) )
                        (progn
                            (vla-move obj1 (vlax-3D-point pt1 ) (vlax-3D-point pt2 ) );this prevents swaping dimmension f autocad meps duct
                            (vla-put-endpoint obj1 (vlax-3D-point intPt) )
                        );progn
                    );if
                (grdraw pt1 intPt 3 1) (grdraw pt4 intPt 3 1)
                );progn
            );if
        );progn
        (alert "Cannot stretch.")
    );if
    ;-----------------------------------------
    ;restoring system variables
    ;-----------------------------------------
    (setq *error* temperr)
    (command "_UCS" "_NA" "_R" "old_ucs1");restoring UCS
    (command "_UCS" "_NA" "_D" "old_ucs1");deleting ucs name.
    (command "_DELAY" 70)
    (redraw)
    (vla-endundomark doc1)
    (princ)
);defun

Example:

Download file: STRETCH_DUCT_TO_INTERSECT_v1_02.FAS