;;;CADALYST 02/05 Tip2017: IntelliJoin.LSP		Intelligent Join	(c) Andrzeg Gumula

;;; [c]2004 Andrzej Gumula, Katowice, Poland
;;; e-mail: a.gumula@wp.pl
;;; This routine allows automatically join entities to one polyline
;;; Join only 2D entities - line, arc, lwpolyline, 2D polyline (without fith/smooth)
;;; Please open and see IntelliJoinHelp.dwg file for help

(defun c:IntelliJoin (/ Variables Values Object Start Check Elem Point StartObj Color Pedit OldLayersList
    	                SSet Count SSElem EndCommand UndoItem TypeJoin Flag MouseReactor Layers PeAc UndoCmd)

 (defun FileError (It)
  (setq *error* OldError)
  (princ (strcat "\nError: " It "\n"))
  (if Object (vla-highlight Object 0))
  (if SSElem (redraw SSElem 4))
  (if MouseReactor (vlr-remove MouseReactor))
  (if Flag
   (progn
    (vl-cmdf "_.regen")
    (vl-cmdf "_.-view" "_r" "IntelliJoinStartView")
    (vl-cmdf "_.-view" "_d" "IntelliJoinStartView")
   )
  );end if
  (if UndoCmd (vl-cmdf "_.undo" "_e"))
  (vlax-for & (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object)))
   (if (member (vla-get-name &) OldLayersList)
     (if (/= (vla-get-name &) (getvar "CLAYER")) (vla-put-freeze & :vlax-true))
     (if (/= (vla-get-name &) (getvar "CLAYER")) (vla-put-freeze & :vlax-false))
   );end if
 );end vlax-for
  (mapcar 'setvar Variables Values)
  (if PeAc (setvar "PEDITACCEPT" PeAc))
  (princ)
);end FileError

(defun GetLayers ( / Obj Lock MouseReactor Layer Answer)
 (setq Check nil
       Layers (vla-get-layer Object)
       MouseReactor (VLR-Mouse-Reactor nil '((:VLR-beginRightClick . ReactionButton)))
 )
 (prompt (strcat "\nSelected object is on a \"" Layers "\" layer."))
 (prompt "\nDefault the routine will be join only entities drawn on this layer. ")
 (initget "Yes No")
 (setq Answer (cond
		((getkword "\nDo you want to take into account another layers? No,[Yes]: "))
		 (T "Yes")))
 (if (= Answer "Yes")
  (while (not Check)
   (if (setq Obj (entsel "\nSelect other object(s) to take into account another layer(s) (pick right button mouse to select all layer): "))
    (setq Lock (cdr (assoc 70 (tblsearch "LAYER" (setq Layer (cdr (assoc 8 (entget (car Obj)))))))))
    (setq Check T)
   );end if
   (if (and Lock (= 4 (logand 4 Lock)))
    (princ "\nEntity on a locked layer. Entities on this layer won't be take into accout.\nPlease select another...")
    (if (and Obj (not (wcmatch Layer Layers)))
      (progn
       (setq Layers (strcat Layers "," Layer))
       (prompt (strcat "\nSelected layer - \"" Layer "\""))
      )
    );end if
   );end if
   (setq Obj nil)
  );end while
 );end if
 (vlr-remove MouseReactor)
);end GetLayers
   
  (defun SetZoom (It / Count X Y XX YY)
   (repeat (setq Count (sslength It))
    (setq Count (1- Count))
    (vla-getboundingbox (vlax-ename->vla-object (ssname It Count)) 'X 'Y)
    (setq XX (cons (car (trans (vlax-safearray->list X) 0 1)) XX)
 	  YY (cons (cadr (trans (vlax-safearray->list X) 0 1)) YY)
	  XX (cons (car (trans (vlax-safearray->list Y) 0 1)) XX)
	  YY (cons (cadr (trans (vlax-safearray->list Y) 0 1)) YY)
	  XX (cons (car (trans Point 0 1)) XX)
	  YY (cons (cadr (trans Point 0 1)) YY))
   );end repeat
   (vl-cmdf "_.zoom" "_w"  (list (apply 'min XX) (apply 'min YY)) (list (apply 'max XX) (apply 'max YY))
	    "_.zoom" "_s" "0.8x")
 );end SetZoom
       
 (defun ReactionButton (Reactor Pt)
  (setq Check T Layers (list->str (vla-List-Layers-Locked)))
 );end ReactionButtom
  
 (defun SelectObj (Msg / Tmp)
  (setq Check nil
	MouseReactor (VLR-Mouse-Reactor nil '((:VLR-beginRightClick . ReactionButton))))
  (while (not Check)
   (if (setq Elem (entsel Msg))
    (if (not (setq Check (ssget (cadr Elem) (GetFilter))))
     (prompt "\nIncorrect entity or entity on a locked layer. ")
    );end if
   );end if
  );end while
  (vlr-remove MouseReactor)
  (setq MouseReactor nil)
  (if (= (type Check) 'PICKSET)
   (progn
    (redraw (ssname Check 0) 3)
    (redraw)
    (vlax-ename->vla-object (ssname Check 0))
   )
  );end if
 );end SelectObj

 (defun vlax-curve-CheckPointPosition (Obj Pt)
  (if (< (vlax-curve-GetDistAtPoint Obj (vlax-curve-getClosestPointTo Obj (trans Pt 1 0) T))
         (*  (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 0.5)) 
   T
   nil
  );end if
 );end vlax-curve-CheckPointPosition

(defun vla-List-Layers-Locked (/  out)
 (vlax-for & 
   (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object)))
     (if (equal (vlax-get-property & 'Lock) :vlax-false)
         (setq out (cons (vla-get-Name &) out))
     )
 )
 (if out out '(""))
);end vla-List-Layers-Locked

(defun vla-List-Layers-Freeze (/  out)
 (vlax-for & 
   (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object)))
     (if (equal (vlax-get-property & 'Freeze) :vlax-true)
         (setq out (cons (vla-get-Name &) out))
     )
 )
 out
);end vla-List-Layers-Freeze

(defun list->str (LayList / String)
 (foreach & LayList 
  (if (not String) (setq String &)
    (setq String (strcat String "," &))
  )
)
);end list->str

(defun GetCirclePts (Center Radius Value / Ang Pts)
 (setq Ang 0)
 (repeat Value
  (setq Pts (cons (polar Center Ang Radius) Pts)
        Ang (+ Ang (/ (* 2 pi) Value))) 
 );end repeat
 Pts
);end GetCirclePts

(defun GetFilter ()
 (list '(-4 . "<AND")
           (if Layers (cons 8 Layers) (cons 8 (list->str (vla-List-Layers-Locked))))
          '(-4 . "<OR")
          '(-4 . "<AND")
            '(0 . "LINE")
            '(-4 . "*,*,=") '(10 0.0 0.0 0.0)
            '(-4 . "*,*,=") '(11 0.0 0.0 0.0)
          '(-4 . "AND>")
          '(-4 . "<AND")
            '(0 . "ARC")
            '(210 0.0 0.0 1.0)
            '(-4 . "*,*,=") '(10 0.0 0.0 0.0)
          '(-4 . "AND>")
           '(-4 . "<AND")
             '(0 . "LWPOLYLINE")
             '(38 . 0.0)
             '(210 0.0 0.0 1.0)
             '(-4 . "<NOT") 
               '(-4 . "&") '(70 . 1)
             '(-4 . "NOT>")  
           '(-4 . "AND>")
           '(-4 . "<AND")
             '(0 . "POLYLINE")
             '(100 . "AcDb2dPolyline")
             '(210 0.0 0.0 1.0)
             '(-4 . "*,*,=") '(10 0.0 0.0 0.0)       
             '(70 . 0)
             '(75 . 0)
           '(-4 . "AND>")
          '(-4 . "OR>")
         '(-4 . "AND>")
 )
);endGetFilter
  
(defun MakeSet (Pt / Tmp Item Obj)
 (if (zerop RangeForIntelliJoin)
  (setq Tmp (ssget "_C" Pt Pt (GetFilter)))
  (setq Tmp (ssget "_CP" (GetCirclePts Pt RangeForIntelliJoin 512) (GetFilter)))
 );end if
 (if Tmp
  (progn
   (ssdel (vlax-vla-object->ename Object) Tmp)
    (repeat (setq Item (sslength Tmp))
     (setq Item (1- Item)
	   Obj (vlax-ename->vla-object (ssname Tmp Item)))
     (if (and (> (distance (trans Pt 1 0) (vlax-curve-getStartPoint Obj)) RangeForIntelliJoin)
	      (> (distance (trans Pt 1 0) (vlax-curve-getEndPoint Obj)) RangeForIntelliJoin))
       (ssdel (vlax-vla-object->ename Obj) Tmp)
     )
    );end repeat
  )
 );end if
  (if (and Tmp (zerop (sslength Tmp)))
  nil
  Tmp
 );end if
);end MakeSet

(defun MakeLine (Pt1 Pt2)
 (if (entmake (list '(0 . "LINE") (cons 10 Pt1) (cons 11 Pt2)))
  (entlast)
  nil
 );end if
);end MakeLine

(defun CreateJoin (Obj Join / Start End Line Tmp)

 (defun GetInts (Ent1 Ent2 / VarPts Lst Return Pts PtInt)
  (setq VarPts (vla-IntersectWith Ent1 Ent2 acExtendBoth))
  (cond
   ((not (minusp (vlax-safearray-get-u-bound (vlax-variant-value VarPts) 1)))
    (setq Lst (vlax-safearray->list (vlax-variant-value VarPts)))
    (repeat (/ (length Lst) 3)
     (setq Return (cons (list (car Lst) (cadr Lst) (caddr Lst)) Return)
           Lst (cdddr Lst))
    );end repeat
   )
  );end cond
  (if Return
   (progn
    (setq Tmp (car Return))
    (foreach & Return (if (< (distance & Point) (distance Tmp Point)) (setq Tmp &)))
   )
  );end if
  Tmp
);end GetInts

 (setq Start (vlax-curve-getStartPoint (vlax-ename->vla-object Obj))
       End (vlax-curve-getEndPoint (vlax-ename->vla-object Obj)))
 (cond
  ((or (equal Point Start 1.0e-010) (equal Point End 1.0e-010))
   (if (member (vla-get-ObjectName Object) '("AcDbLine" "AcDbArc"))
    (setq Pedit (vl-cmdf "_.pedit" (vlax-vla-object->ename Object) "_y" "_j" Obj "" ""))
    (setq Pedit (vl-cmdf "_.pedit" (vlax-vla-object->ename Object) "_j" Obj "" ""))
   );end if
   (if (vlax-erased-p Object) (setq Object (vlax-ename->vla-object (entlast))))
  )
  ((member Join '("Fillet" "Both"))
    (setq PtInt (GetInts Object (vlax-ename->vla-object Obj)))
    (if (and PtInt (not (vlax-curve-GetParamAtPoint Object PtInt)))
     (progn
      (vl-cmdf "_.extend" Obj "" (list (vlax-vla-object->ename Object) (trans Point 0 1)) "")
      (if (equal OtherEnd (setq Point (vlax-curve-getStartPoint Object)))
       (setq Point (vlax-curve-getEndPoint Object))
      );end if
     )
    );end if
    (if (and PtInt (not (vlax-curve-GetParamAtPoint (vlax-ename->vla-object Obj) PtInt)))
     (progn
      (vl-cmdf "_.extend" (vlax-vla-object->ename Object) "" (list Obj (if (< (distance Start Point) (distance End Point)) (trans Start 0 1) (trans End 0 1))) "")
      (setq Start (vlax-curve-getStartPoint (vlax-ename->vla-object Obj))
            End (vlax-curve-getEndPoint (vlax-ename->vla-object Obj))
      )
     )
    );end if
    (setq PtInt (GetInts Object (vlax-ename->vla-object Obj)))
    (if (and PtInt (vlax-curve-getParamAtPoint Object PtInt) (not (equal PtInt Point 1.0e-010)))
    (progn
     (vl-cmdf "_.break" (list (vlax-vla-object->ename Object) (trans PtInt 0 1)) (trans Point 0 1))
     (if (vlax-erased-p Object) (setq Object (vlax-ename->vla-object (entlast))))
     (if (equal OtherEnd (setq Point (vlax-curve-getStartPoint Object)))
      (setq Point (vlax-curve-getEndPoint Object))
     );end if
    )
   );end if
   (if (and PtInt (vlax-curve-getParamAtPoint (vlax-ename->vla-object Obj) PtInt) (not (equal PtInt (if (< (distance Start Point) (distance End Point)) Start End) 1.0e-010)))
    (progn
     (vl-cmdf "_.break" (list Obj (trans PtInt 0 1)) (if (< (distance Start Point) (distance End Point)) (trans Start 0 1) (trans End 0 1)))
     (setq Start (vlax-curve-getStartPoint (vlax-ename->vla-object (if (entget Obj) Obj (setq Obj (entlast)))))
           End (vlax-curve-getEndPoint (vlax-ename->vla-object (if (entget Obj) Obj (setq Obj (entlast))))))
    )
   );end if
   (if (or (= Join "Both")
	   (and (= Join "Fillet") (or (equal Point Start 1.0e-010)
				      (equal Point End 1.0e-010))))
    (CreateJoin Obj "Add")
    (progn
     (prompt "\nCan't create the join. ")
     (setq EndCommand T)
    )
   );end if
  )
  ((= Join "Add")
     (if (< (distance Start Point) (distance End Point))
       (setq Line (MakeLine Start Point))
       (setq Line (MakeLine End Point))
     );end if
    (if Line
     (progn
      (if (member (vla-get-ObjectName Object) '("AcDbLine" "AcDbArc"))
       (setq Pedit (vl-cmdf "_.pedit" (vlax-vla-object->ename Object) "_y" "_j" Line Obj "" ""))
       (setq Pedit (vl-cmdf "_.pedit" (vlax-vla-object->ename Object) "_j" Line Obj "" ""))
      );end if
      (if (vlax-erased-p Object) (setq Object (vlax-ename->vla-object (entlast))))
     )
    );end if
  )
 );end cond
);end CreateJoin

(defun Undo ()
 (cond
  ((> UndoItem 0)
   (vl-cmdf "_.undo" "_back")
   (setq UndoItem (1- UndoItem))
   (if (vlax-erased-p Object) (setq Object StartObj))
   T
  )
  (T (prompt "\nNothing to undo. "))
 );end cond
);end Undo

(defun DrawCursor (Pt Size / Ang Pts)
 (setq Ang 0.0)
 (repeat 16
  (setq Pts (cons Pt (cons (polar Pt Ang Size) Pts))
        Ang (+ Ang (/ (* 2 pi) 16))) 
 );end repeat
 (grvecs (append (list Color) Pts))
);end DrawCursor

(setq OldError *error* *error* FileError)  
(setq Variables '("osmode" "highlight" "cmdecho" "trimmode" "ucsview" "dimzin" "lwdisplay" "clayer")
      Values (mapcar 'getvar Variables)
      UndoItem 0)
(if (setq PeAc (getvar "PEDITACCEPT"))
  (setvar "PEDITACCEPT" 0); for A2005 and older
);end if
(vl-load-com)
(setq UndoCmd (vl-cmdf "_.undo" "_be"))
(cond
 ((setq Object (SelectObj "\nSelect entity to join (pick right button mouse to cancel): "))
  (mapcar 'setvar Variables (list 0 1 0 1 0 0 0  (vla-get-layer Object)))
  (setq Flag (vl-cmdf "_.-view" "_s" "IntelliJoinStartView"))
  (setq OldLayersList (vla-list-layers-Freeze))
  (GetLayers)
  (vlax-for & (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object)))
   (if (not (wcmatch (vla-get-name &) Layers))
     (vla-put-freeze & :vlax-true)
   );end if
  );end vlax-for
  (setq StartObj Object
	Color (vla-get-color Object))
  (if (= Color 256) (setq Color (cdr (assoc 62 (tblsearch "layer" (vla-get-layer Object))))))
  (initget "Add Fillet Both")
  (setq TypeJoin (cond
		  (
		   (getkword "\nJoin type - Add, Fillet, <Both>: "))
		  (T "Both")))
  
  (if (vlax-curve-CheckPointPosition Object (cadr Elem))
   (setq Point (vlax-curve-getStartPoint Object)
         OtherEnd (vlax-curve-getEndPoint Object)
   )
   (setq Point (vlax-curve-getEndPoint Object)
         OtherEnd (vlax-curve-getStartPoint Object)
   )
  );end if
  (initget 4)
  (if (or (not RangeForIntelliJoin) (not (numberp RangeForIntelliJoin))) (setq RangeForIntelliJoin 0.0))
  (setq RangeForIntelliJoin (cond
		  ((getdist (strcat "\nFuzz distance <" (rtos RangeForIntelliJoin 2 (getvar "LUPREC")) ">: ")))  
                  (T RangeForIntelliJoin))
  )
  (while (and (not EndCommand) (setq SSet (MakeSet (trans Point 0 1))))
    (vla-highlight Object 1)
    (setq Count (sslength SSet))
    (SetZoom SSet)
    (while (not (minusp Count)) 
     (setq Count (1- Count))
     (cond
      ((= 1 (sslength SSet))
       (CreateJoin (ssname SSet 0) TypeJoin)
       (setq Count -1)
      )
      (T (setq SSElem (ssname SSet Count))
         (redraw SSElem 3)
         (DrawCursor (trans Point 0 1) (/ (getvar "VIEWSIZE") 100.0))
         (initget "Join Next Undo End Object All Polyline")
         (setq Answer (cond
		       ((getkword "\nSelect options [<Join>, Next, zoom at Object, zoom All, zoom at Polyline, Undo, End]?: "))
		       (T "Join")))
         (cond
	  ((= Answer "Join")
	   (vl-cmdf "_.undo" "_m")
	   (setq UndoItem (1+ UndoItem))
	   (CreateJoin SSElem TypeJoin)
	   (setq Count -1)
	  )
	  ((= Answer "Next")
	   (redraw SSElem 4)
	   (if (minusp (1- Count)) (setq Count (sslength SSet)))
	  )
	  ((= Answer "Undo")
	   (if (Undo)
	   (progn
	    (redraw SSElem 4)
	    (vla-highlight Object 1)
	    (setq Count -1)
	   )
	    (setq Count (1+ Count))
	   );end if
	  )
	  ((= Answer "Object")
           (SetZoom (ssadd SSElem))
           (setq Count (1+ Count))
	  )
	  ((= Answer "All")
           (SetZoom SSet)
           (setq Count (1+ Count))
	  )
	  ((= Answer "Polyline")
           (SetZoom (ssadd (vlax-vla-object->ename Object)))
           (setq Count (1+ Count))
	  )
	  ((= Answer "End")
	   (redraw SSElem 4)
	   (setq EndCommand T Count -1)
	  )
	 );end cond
      )
     );end cond
    );end while
   (if (equal OtherEnd (setq Point (vlax-curve-getStartPoint Object)) 1.0e-010)
     (setq Point (vlax-curve-getEndPoint Object))
   );end if
   (redraw)
   (vl-cmdf "_.zoom" "_c" (trans Point 0 1) (if (zerop RangeForIntelliJoin) 10.0 (* 2.5 RangeForIntelliJoin)))
  );end while
 )
);end cond

 (vlax-for & (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object)))
   (if (member (vla-get-name &) OldLayersList)
     (if (/= (vla-get-name &) (getvar "CLAYER")) (vla-put-freeze & :vlax-true))
     (if (/= (vla-get-name &) (getvar "CLAYER")) (vla-put-freeze & :vlax-false))
   );end if
 );end vlax-for

 (if Flag
  (progn
   (vl-cmdf "_.regen")
   (vl-cmdf "_.-view" "_r" "IntelliJoinStartView")
   (setq Flag (not (vl-cmdf "_.-view" "_d" "IntelliJoinStartView")))
  )
 );end if
 (if UndoCmd (vl-cmdf "_.undo" "_e"))
 (mapcar 'setvar Variables Values)
 (if PeAc (setvar "PEDITACCEPT" PeAc))
 (if (not Pedit) (prompt "\Nothing to join. "))
 (if Object (vla-highlight Object 0))
 (setq *error* OldError)
 (princ)
);end file

(prompt "\nLoaded new command IntelliJoin. ")
(prompt "\n[c]2004 Andrzej Gumula. ")
(princ)