Jump to content

Create boundary between two close polylines

Guest

By Guest
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Guest

Guest

Posted
Posted

Hi. I am searching for a lisp code to create boundary between 2 overlapping close polylines like the photo. I know that i can use bounady command but sometimes the drawing is not so clean  and  simple (must have hatch ot blocks , etc).

 

I use for multi boundaries this code, but creates boundaries to all areas in the selection. In the example, you can see a red close polyline and a white close polyline. I want to select red and white polylines and create the green boundary in the overlapping area.

  

(defun c:test ( / *error* big ent enx idx int lst pt1 pt2 rtn sel spc tmp tot val var vtx )


    (defun *error* ( msg )
        (foreach obj rtn
            (if (and (vlax-write-enabled-p obj) (not (vlax-erased-p obj)))
                (vla-delete obj)
            )
        )
        (mapcar 'setvar var val)
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

    (LM:startundo (LM:acdoc))
    (cond
        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
            (princ "\nCurrent layer locked.")
        )
        (   (setq sel
                (LM:ssget "\nSelect Lines or Polylines: "
                    (list
                        (list
                           '(-4 . "<OR")
                               '(0 . "LINE")
                               '(-4 . "<AND")
                                   '(0 . "LWPOLYLINE")
                                   '(-4 . "<NOT")
                                       '(-4 . "<>")
                                       '(42 . 0.0)
                                   '(-4 . "NOT>")
                               '(-4 . "AND>")
                           '(-4 . "OR>")
                            (if (= 1 (getvar 'cvport))
                                (cons 410 (getvar 'ctab))
                               '(410 . "Model")
                            )
                        )
                    )
                )
            )
            (setq spc
                (vlax-get-property (LM:acdoc)
                    (if (= 1 (getvar 'cvport))
                        'paperspace
                        'modelspace
                    )
                )
            )
            (repeat (setq idx (sslength sel))
                (if (= "LINE" (cdr (assoc 0 (setq enx (entget (ssname sel (setq idx (1- idx))))))))
                    (setq lst (cons (list (cdr (assoc 10 enx)) (cdr (assoc 11 enx))) lst))
                    (setq vtx (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx))
                          vtx (mapcar 'list vtx (if (= 1 (logand 1 (cdr (assoc 70 enx)))) (cons (last vtx) vtx) (cdr vtx)))
                          lst (append vtx lst)
                    )
                )
            )
            (foreach pl1 lst
                (setq pt1 (car  pl1)
                      pt2 (cadr pl1)
                )
                (foreach pl2 lst
                    (if
                        (and
                            (not (equal pl1 pl2 1e-8))
                            (setq int (inters pt1 pt2 (car pl2) (cadr pl2)))
                            (not (vl-member-if '(lambda ( pnt ) (equal pnt int 1e-8)) pl1))
                        )
                        (setq pl1 (cons int pl1))
                    )
                )
                (setq rtn
                    (append
                        (mapcar
                            (function
                                (lambda ( a b )
                                    (vla-addline spc
                                        (vlax-3D-point a)
                                        (vlax-3D-point b)
                                    )
                                )
                            )
                            (setq pl1
                                (vl-sort pl1
                                    (function
                                        (lambda ( a b )
                                            (< (distance pt1 a) (distance pt1 b))
                                        )
                                    )
                                )
                            )
                            (cdr pl1)
                        )
                        rtn
                    )
                )
            )
            (setq var '(cmdecho peditaccept)
                  val  (mapcar 'getvar var)
                  tot  0.0
            )
            (mapcar 'setvar var '(0 1))
            (foreach reg (vlax-invoke spc 'addregion rtn)
                (setq ent (entlast))
                (command "_.pedit" "_m")
                (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke reg 'explode)))
                (command "" "_j" "" "")
                (if
                    (and
                        (not (eq ent (setq ent (entlast))))
                        (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
                    )
                    (progn
                        (setq tmp (vlax-curve-getarea ent)
                              tot (+ tot tmp)
                        )
                        (if (< (car big) tmp)
                            (setq big (list tmp ent))
                        )
                    )
                )
                (vla-delete reg)
            )
            (if (equal (car big) (/ tot 2.0) 1e-3) ;; Gian Paolo Cattaneo
                (entdel (cadr big))
            )
            (foreach obj rtn (vla-delete obj))
            (mapcar 'setvar var val)
        )
    )
    (LM:endundo (LM:acdoc))


    (princ)
)

;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)
(vl-load-com) (princ)

 

 

Thanks

test.jpg

Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

I don't quite have a time to test, but I suppose you wanted something like this :

  

(defun c:2cur-int-cur ( / vl-load *error* cmdfun cmderr catch_cont apply_cadr->car ftoa reversecurve mid sysvarlst sysvarvals initvalueslst ti s1 c1 q1 s2 c2 q2 k ii p1 p2 e1 e2 ex ) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;;

  (defun vl-load nil
    (or cad
      (cond
        ( (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil)))
          (setq cad (vlax-get-acad-object))
        )
        ( t
          (vl-load-com)
          (setq cad (vlax-get-acad-object))
        )
      )
    )
    (or doc (setq doc (vla-get-activedocument cad)))
    (or alo (setq alo (vla-get-activelayout doc)))
    (or spc (setq spc (vla-get-block alo)))
  )

  ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
  (or (and cad doc alo spc) (vl-load))

  (defun *error* ( m )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if (not (cmdfun (list "_.UNDO" "_E") t))
        (cmderr 23)
        (if doc
          (vla-endundomark doc)
        )
      )
    )
    (if initvalueslst
      (mapcar (function apply_cadr->car) initvalueslst)
    )
    (if doc
      (vla-regen doc acactiveviewport)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun cmdfun ( tokenslist flag ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
    (if command-s
      (if flag
        (if (not (vl-catch-all-error-p (vl-catch-all-apply (function command-s) tokenslist)))
          flag
        )
        (apply (function command-s) tokenslist)
      )
      (if flag
        (apply (function vl-cmdf) tokenslist)
        (apply (function command) tokenslist)
      )
    )
  )

  (defun cmderr ( linenum ) ;;; linenum - integer representing line number at which used (cmdfun) failed with success execution ;;;
    (prompt (strcat "\ncommand execution failure... error at line " (itoa linenum) " ..."))
  )

  (defun catch_cont ( ctch / gr )
    (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
    (while
      (and
        (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
        (setq gr (grread))
        (or
          (/= (car gr) 3)
          (not (equal gr (list 2 13)))
        )
      )
    )
    (if (vl-catch-all-error-p ctch)
      ctch
    )
  )

  (defun apply_cadr->car ( sysvarvaluepair / ctch )
    (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
    (if (vl-catch-all-error-p ctch)
      (progn
        (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
        (catch_cont ctch)
      )
    )
  )

  (defun ftoa ( n / m a s b )
    (if (numberp n)
      (progn
        (setq m (fix ((if (< n 0) - +) n 1e-8)))
        (setq a (abs (- n m)))
        (setq m (itoa m))
        (setq s "")
        (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
          (setq s (strcat s (itoa b)))
          (setq a (- (* a 10.0) b))
        )
        (if (= (type n) (quote int))
          m
          (if (= s "")
            m
            (if (and (= m "0") (< n 0))
              (strcat "-" m "." s)
              (strcat m "." s)
            )
          )
        )
      )
    )
  )

  (defun reversecurve ( curve / rlw r3dp rhpl rspl rhel rli rell rarc rci )

    (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
      ;; by ElpanovEvgeniy
      (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
        (progn
          (foreach a1 e
            (cond
              ( (= (car a1) 10) (setq x2 (cons a1 x2)) )
              ( (= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)) )
              ( (= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)) )
              ( (= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)) )
              ( (= (car a1) 210) (setq x6 (cons a1 x6)) )
              ( t (setq x1 (cons a1 x1)) )
            )
          )
          (entmod
            (append
              (reverse x1)
              (append
                (apply (function append)
                  (apply (function mapcar)
                    (cons (function list)
                      (list
                        x2
                        (cdr (reverse (cons (car x3) (reverse x3))))
                        (cdr (reverse (cons (car x4) (reverse x4))))
                        (cdr (reverse (cons (car x5) (reverse x5))))
                      )
                    )
                  )
                )
                x6
              )
            )
          )
          (entupd lw)
        )
      )
    )

    ;; Reverse HELIX - Marko Ribar, d.i.a.
    (defun rhel ( hel / enx enx1 enx2 v x1 x2 x3 )
      (if (= (cdr (assoc 0 (setq enx (entget hel)))) "HELIX")
        (progn
          (setq enx1 (reverse (cdr (member (cons 100 "AcDbHelix") (reverse enx)))) enx2 (member (cons 100 "AcDbHelix") enx))
          (foreach a1 enx1
            (cond
              ( (= (car a1) 40) (setq x2 (cons a1 x2)) )
              ( (= (car a1) 10) (setq x3 (cons a1 x3)) )
              ( t (setq x1 (cons a1 x1)) )
            )
          )
          (setq enx2 (subst (cons 40 (distance (cdr (assoc 10 enx2)) (cdr (assoc 11 enx2)))) (assoc 40 enx2) enx2) enx2 (subst (cons 10 (mapcar (function +) (cdr (assoc 10 enx2)) (mapcar (function *) (cdr (assoc 12 enx2)) (list (* (cdr (assoc 41 enx2)) (cdr (assoc 42 enx2))) (* (cdr (assoc 41 enx2)) (cdr (assoc 42 enx2))) (* (cdr (assoc 41 enx2)) (cdr (assoc 42 enx2))))))) (assoc 10 enx2) enx2) enx2 (subst (cons 11 (cdr (car x3))) (assoc 11 enx2) enx2) enx2 (subst (cons 12 (mapcar (function -) (cdr (assoc 12 enx2)))) (assoc 12 enx2) enx2))
          (entmod
            (append
              (reverse x1)
              (mapcar
                (function (lambda ( x )
                  (cons 40 (- (cdar x2) (cdr x)))
                ))
                x2
              )
              x3
              enx2
            )
          )
          (entupd hel)
        )
      )
    )

    ;; Reverse LINE - Marko Ribar, d.i.a.
    (defun rli ( li / enx sp ep )
      (if (= (cdr (assoc 0 (setq enx (entget li)))) "LINE")
        (progn
          (setq sp (cdr (assoc 10 enx)))
          (setq ep (cdr (assoc 11 enx)))
          (setq enx (subst (cons 10 ep) (assoc 10 enx) enx))
          (setq enx (subst (cons 11 sp) (assoc 11 enx) enx))
          (entmod enx)
          (entupd li)
        )
      )
    )

    ;; Reverse SPLINE - Marko Ribar, d.i.a.
    (defun rspl ( spl / enx x12 x13 x1 x2 x3 x4 x5 )
      (if (= (cdr (assoc 0 (setq enx (entget spl)))) "SPLINE")
        (progn
          (foreach a1 enx
            (cond
              ( (= (car a1) 12) (setq x13 (cons (cons 13 (mapcar (function -) (cdr a1))) x13)) )
              ( (= (car a1) 13) (setq x12 (cons (cons 12 (mapcar (function -) (cdr a1))) x12)) )
              ( (= (car a1) 40) (setq x2 (cons a1 x2)) )
              ( (= (car a1) 10) (setq x3 (cons a1 x3)) )
              ( (= (car a1) 41) (setq x4 (cons a1 x4)) )
              ( (= (car a1) 11) (setq x5 (cons a1 x5)) )
              ( t (setq x1 (cons a1 x1)) )
            )
          )
          (entmod
            (append
              (reverse x1)
              x12
              x13
              (mapcar
                (function (lambda ( x )
                  (cons 40 (- (cdar x2) (cdr x)))
                ))
                x2
              )
              (if x4
                (apply (function append)
                  (mapcar
                    (function (lambda ( a b )
                      (list a b)
                    ))
                    x3
                    x4
                  )
                )
                x3
              )
              x5
            )
          )
          (entupd spl)
        )
      )
    )

    ;; Reverse 3DPOLYLINE - Marko Ribar, d.i.a.
    (defun r3dp ( 3dp / r3dppol typ )

      (defun r3dppol ( 3dp / v p pl sfa var )
        (setq v 3dp)
        (while (= (cdr (assoc 0 (entget (setq v (entnext v))))) "VERTEX")
          (setq p (cdr (assoc 10 (entget v))) pl (cons p pl))
        )
        (setq pl (apply (function append) pl) sfa (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pl)))))
        (vlax-safearray-fill sfa pl)
        (setq var (vlax-make-variant sfa))
        (vla-put-coordinates (vlax-ename->vla-object 3dp) var)
        (entupd 3dp)
      )

      (setq typ (vla-get-type (vlax-ename->vla-object 3dp)))
      (vla-put-type (vlax-ename->vla-object 3dp) acsimplepoly)
      (r3dppol 3dp)
      (if typ (vla-put-type (vlax-ename->vla-object 3dp) typ))
      (entupd 3dp)
    )

    ;; Reverse old heavy 2d POLYLINE - Marko Ribar, d.i.a. - sub functions by Roy at Theswamp.org
    (defun rhpl ( hpl / KGA_List_Divide_3 KGA_List_IndexSeqMakeLength KGA_Geom_PolylineReverse )

      (defun KGA_List_Divide_3 ( lst / ret )
        (repeat (/ (length lst) 3)
          (setq ret (cons (list (car lst) (cadr lst) (caddr lst)) ret) lst (cdddr lst))
        )
        (reverse ret)
      )

      ; Make a zero based list of integers.
      (defun KGA_List_IndexSeqMakeLength ( len / ret )
        (repeat (rem len 4)
          (setq ret (cons (setq len (1- len)) ret))
        )
        (repeat (/ len 4)
          (setq ret (vl-list* (- len 4) (- len 3) (- len 2) (- len 1) ret) len (- len 4))
        )
        ret
      )

      ; Obj must be an "AcDb2dPolyline" of the acsimplepoly type or an "AcDbPolyline".
      (defun KGA_Geom_PolylineReverse ( obj / typ bulgeLst idxLst ptLst widLst conWid v vx )
        (setq typ (vla-get-type obj))
        (vla-put-type obj acsimplepoly)
        (setq ptLst (KGA_List_Divide_3 (vlax-get obj 'coordinates)) idxLst (KGA_List_IndexSeqMakeLength (1+ (length ptLst))) v (vlax-vla-object->ename obj))
        (while (= (cdr (assoc 0 (setq vx (entget (setq v (entnext v)))))) "VERTEX")
          (setq widLst (cons (list (cdr (assoc 40 vx)) (cdr (assoc 41 vx))) widLst) bulgeLst (cons (cdr (assoc 42 vx)) bulgeLst))
        )
        (if (vl-catch-all-error-p (setq conWid (vl-catch-all-apply (function vla-get-constantwidth) (list obj))))
          (mapcar
            (function (lambda ( idx pt bulge widSub )
              (vla-put-coordinate obj idx (vlax-3d-point pt))
              (vla-setbulge obj idx (- bulge))
              (vla-setwidth obj idx (cadr widSub) (car widSub))
            ))
            idxLst
            (reverse ptLst)
            (append
              (cdr bulgeLst)
              (list (car bulgeLst))
            )
            (append
              (cdr widLst)
              (list (car widLst))
            )
          )
          (progn
            (mapcar
              (function (lambda ( idx pt bulge widSub )
                (vla-put-coordinate obj idx (vlax-3d-point pt))
                (vla-setbulge obj idx (- bulge))
              ))
              idxLst
              (reverse ptLst)
              (append
                (cdr bulgeLst)
                (list (car bulgeLst))
              )
            )
            (vla-put-constantwidth obj conWid)
          )
        )
        (if typ (vla-put-type obj typ))
      )

      (KGA_Geom_PolylineReverse (vlax-ename->vla-object hpl))
      (entupd hpl)
    )

    (defun rell ( ell / ELL:point->param ellx ocs p1 p2 dxf dxf41 dxf42 )

      (defun ELL:point->param ( dxf pnt / ang ocs )
        (setq ocs (cdr (assoc 210 dxf))
              ang (- (angle (trans (cdr (assoc 10 dxf)) 0 ocs) (trans pnt 0 ocs))
                     (angle (list 0.0 0.0) (trans (cdr (assoc 11 dxf)) 0 ocs))
                  )
        )
        (atan (sin ang) (* (cdr (assoc 40 dxf)) (cos ang)))
      )

      (setq ellx (entget ell))
      (setq ocs (cdr (assoc 210 ellx)))
      (setq p1 (vlax-curve-getstartpoint ell) p2 (vlax-curve-getendpoint ell))
      (setq dxf (list (assoc 10 ellx) (cons 11 (mapcar (function -) (cdr (assoc 11 ellx)))) (assoc 40 ellx) (cons 210 (mapcar (function -) ocs))))
      (if (and (equal p1 (mapcar (function +) (cdr (assoc 10 ellx)) (cdr (assoc 11 ellx))) 1e-6) (equal p2 (mapcar (function +) (cdr (assoc 10 ellx)) (cdr (assoc 11 ellx))) 1e-6))
        (setq dxf41 0.0 dxf42 (* 2 pi))
        (setq dxf41 (ELL:point->param dxf p2) dxf42 (ELL:point->param dxf p1))
      )
      (setq ellx (subst (cons 11 (mapcar (function -) (cdr (assoc 11 ellx)))) (assoc 11 ellx) ellx))
      (setq ellx (subst (cons 41 dxf41) (assoc 41 ellx) ellx))
      (setq ellx (subst (cons 42 dxf42) (assoc 42 ellx) ellx))
      (setq ellx (subst (cons 210 (mapcar (function -) ocs)) (assoc 210 ellx) ellx))
      (entupd (cdr (assoc -1 (entmod ellx))))
    )

    (defun rarc ( arc / arcx cw ocs dxf50 dxf51 )
      (setq arcx (entget arc))
      (setq cw (trans (cdr (assoc 10 arcx)) arc 0))
      (setq ocs (cdr (assoc 210 arcx)))
      (setq dxf50 (cdr (assoc 50 arcx)) dxf51 (cdr (assoc 51 arcx)))
      (setq arcx (subst (cons 50 (- pi dxf51)) (assoc 50 arcx) arcx))
      (setq arcx (subst (cons 51 (- pi dxf50)) (assoc 51 arcx) arcx))
      (setq arcx (subst (cons 10 (trans cw 0 (mapcar (function -) ocs))) (assoc 10 arcx) arcx))
      (setq arcx (subst (cons 210 (mapcar (function -) ocs)) (assoc 210 arcx) arcx))
      (entupd (cdr (assoc -1 (entmod arcx))))
    )

    (defun rci ( ci / cix cw ocs )
      (setq cix (entget ci))
      (setq cw (trans (cdr (assoc 10 cix)) ci 0))
      (setq ocs (cdr (assoc 210 cix)))
      (setq cix (subst (cons 10 (trans cw 0 (mapcar (function -) ocs))) (assoc 10 cix) cix))
      (setq cix (subst (cons 210 (mapcar (function -) ocs)) (assoc 210 cix) cix))
      (entupd (cdr (assoc -1 (entmod cix))))
    )

    (cond
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbLine") (rli curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbHelix") (rhel curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDb2dPolyline") (rhpl curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDb3dPolyline") (r3dp curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbPolyline") (rlw curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbSpline") (rspl curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbEllipse") (rell curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbArc") (rarc curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbCircle") (rci curve) )
    )
  )

  (defun mid ( p1 p2 )
    (mapcar
      (function (lambda ( a b )
        (/ (+ a b) 2.0)
      ))
      p1
      p2
    )
  )

  (setq sysvarlst (list (quote cmdecho) (quote 3dosmode) (quote osmode) (quote unitmode) (quote filedia) (quote cmddia) (quote ucsvp) (quote ucsortho) (quote projmode) (quote orbitautotarget) (quote insunits) (quote hpseparate) (quote hpgaptol) (quote halogap) (quote edgemode) (quote pickdrag) (quote qtextmode) (quote dragsnap) (quote angdir) (quote aunits) (quote limcheck) (quote gridmode) (quote nomutt) (quote apbox) (quote attdia) (quote autosnap) (quote blipmode) (quote copymode) (quote circlerad) (quote objectisolationmode) (quote highlight) (quote lispinit) (quote layerpmode) (quote fillmode) (quote dragmodeinterrupt) (quote dispsilh) (quote fielddisplay) (quote deletetool) (quote delobj) (quote dblclkedit) (quote celtscale) (quote attreq) (quote explmode) (quote frameselection) (quote ltgapselection) (quote pickfirst) (quote plinegen) (quote plinetype) (quote peditaccept) (quote solidcheck) (quote visretain) (quote regenmode) (quote ltscale) (quote osnapcoord) (quote grips) (quote dragmode) (quote lunits) (quote pickstyle) (quote navvcubedisplay) (quote pickauto) (quote draworderctl) (quote expert) (quote auprec) (quote luprec) (quote pickbox) (quote aperture) (quote osoptions) (quote dimzin) (quote pdmode) (quote pdsize) (quote celweight) (quote cecolor) (quote celtype) (quote clayer)))
  (setq sysvarvals (list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0.0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1.0 2 2 2 2 3 3 3 3 5 6 6 6 6 7 8 35 -1.5 -1 "BYLAYER" "ByLayer" "0"))
  (setq sysvarvals
    (vl-remove nil
      (mapcar
        (function (lambda ( x )
          (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
        ))
        sysvarlst
      )
    )
  )
  (setq sysvarlst
    (vl-remove-if-not
      (function (lambda ( x )
        (getvar x)
      ))
      sysvarlst
    )
  )
  (setq initvalueslst
    (apply (function mapcar)
      (cons (function list)
        (list
          sysvarlst
          (mapcar (function getvar) sysvarlst)
        )
      )
    )
  )
  (apply (function mapcar)
    (cons (function setvar)
      (list
        sysvarlst
        sysvarvals
      )
    )
  )
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (if (not (cmdfun (list "_.UNDO" "_E") t))
      (cmderr 446)
      (if doc
        (vla-endundomark doc)
      )
    )
  )
  (if (not (cmdfun (list "_.UNDO" "_M") t))
    (cmderr 453)
    (if doc
      (vla-startundomark doc)
    )
  )
  (if
    (and
      (setq s1 (entsel "\nPick first curve from the outter side of intermeeting..."))
      (setq c1 (car s1))
      (setq q1 (cadr s1))
      (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-curve-getstartpoint) (list c1))))
      (setq s2 (entsel "\nPick second curve from the outter side of intermeeting..."))
      (setq c2 (car s2))
      (setq q2 (cadr s2))
      (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-curve-getstartpoint) (list c2))))
    )
    (progn
      (setq ti (car (_vl-times)))
      (if
        (and
          (setq ii (vlax-invoke (vlax-ename->vla-object c1) (quote intersectwith) (vlax-ename->vla-object c2) acextendnone))
          (= (length ii) 6)
          (setq p1 (list (car ii) (cadr ii) (caddr ii)))
          (setq p2 (list (nth 3 ii) (nth 4 ii) (nth 5 ii)))
          (not (equal p1 p2 1e-6))
        )
        (progn
          (setq k 0)
          (setq q1 (trans (osnap q1 "_nea") 1 0))
          (setq q2 (trans (osnap q2 "_nea") 1 0))
          (if (not (cmdfun (list "_.BREAK" c1 "_non" (trans q1 0 1) "_non" (trans (vlax-curve-getpointatparam c1 (+ 0.05 (vlax-curve-getparamatpoint c1 q1))) 0 1)) t))
            (cmderr 484)
            (setq k (1+ k))
          )
          (setq s1 (ssadd))
          (if (not (vlax-erased-p c1))
            (progn
              (setq e1 c1)
              (setq e2 (entlast))
            )
            (progn
              (setq e2 (entlast))
              (entdel e2)
              (setq e1 (entlast))
              (entdel e2)
            )
          )
          (ssadd e1 s1)
          (ssadd e2 s1)
          (if (not (cmdfun (list "_.JOIN" s1 "") t))
            (cmderr 503)
            (setq k (1+ k))
          )
          (cond
            (
              (and
                (not (vlax-erased-p e1))
                (not (vlax-erased-p e2))
                (equal p1 (vlax-curve-getclosestpointto e1 p1) 1e-3)
              )
              (setq c1 e1)
            )
            (
              (and
                (not (vlax-erased-p e1))
                (not (vlax-erased-p e2))
                (equal p1 (vlax-curve-getclosestpointto e2 p1) 1e-3)
              )
              (setq c1 e2)
            )
            (
              (and
                (not (vlax-erased-p e1))
                (vlax-erased-p e2)
                (equal p1 (vlax-curve-getclosestpointto e1 p1) 1e-3)
              )
              (setq c1 e1)
            )
            (
              (and
                (vlax-erased-p e1)
                (not (vlax-erased-p e2))
                (equal p1 (vlax-curve-getclosestpointto e2 p1) 1e-3)
              )
              (setq c1 e2)
            )
            ( (equal p1 (vlax-curve-getclosestpointto (entlast) p1) 1e-3)
              (setq c1 (entlast))
            )
          )
          (if (not (cmdfun (list "_.BREAK" c2 "_non" (trans q2 0 1) "_non" (trans (vlax-curve-getpointatparam c2 (+ 0.05 (vlax-curve-getparamatpoint c2 q2))) 0 1)) t))
            (cmderr 544)
            (setq k (1+ k))
          )
          (setq s2 (ssadd))
          (if (not (vlax-erased-p c2))
            (progn
              (setq e1 c2)
              (setq e2 (entlast))
            )
            (progn
              (setq e2 (entlast))
              (entdel e2)
              (setq e1 (entlast))
              (entdel e2)
            )
          )
          (ssadd e1 s2)
          (ssadd e2 s2)
          (if (not (cmdfun (list "_.JOIN" s2 "") t))
            (cmderr 563)
            (setq k (1+ k))
          )
          (cond
            (
              (and
                (not (vlax-erased-p e1))
                (not (vlax-erased-p e2))
                (equal p1 (vlax-curve-getclosestpointto e1 p1) 1e-3)
              )
              (setq c2 e1)
            )
            (
              (and
                (not (vlax-erased-p e1))
                (not (vlax-erased-p e2))
                (equal p1 (vlax-curve-getclosestpointto e2 p1) 1e-3)
              )
              (setq c2 e2)
            )
            (
              (and
                (not (vlax-erased-p e1))
                (vlax-erased-p e2)
                (equal p1 (vlax-curve-getclosestpointto e1 p1) 1e-3)
              )
              (setq c2 e1)
            )
            (
              (and
                (vlax-erased-p e1)
                (not (vlax-erased-p e2))
                (equal p1 (vlax-curve-getclosestpointto e2 p1) 1e-3)
              )
              (setq c2 e2)
            )
            ( (equal p1 (vlax-curve-getclosestpointto (entlast) p1) 1e-3)
              (setq c2 (entlast))
            )
          )
          (if (> (vlax-curve-getparamatpoint c1 p1) (vlax-curve-getparamatpoint c1 p2))
            (setq c1 (reversecurve c1))
          )
          (if (> (vlax-curve-getparamatpoint c2 p1) (vlax-curve-getparamatpoint c2 p2))
            (setq c2 (reversecurve c2))
          )
          (setq ii (trans (mid (vlax-curve-getpointatparam c1 (+ 0.05 (vlax-curve-getparamatpoint c1 p1))) (vlax-curve-getpointatparam c2 (+ 0.05 (vlax-curve-getparamatpoint c2 p1)))) 0 1))
          (if
            (not
              (and
                (/= k 0)
                (cmdfun (list "_.UNDO" k) t)
              )
            )
            (cmderr 617)
          )
          (if (not (cmdfun (list "_.-BOUNDARY" "_A" "_O" "_P" "_I" "_Y" "_B" "_N" (ssadd c1 (ssadd c2)) "" "" "_non" ii "") t))
            (if (not (cmdfun (list "_.-BOUNDARY" "_A" "_O" "_R" "_I" "_Y" "_B" "_N" (ssadd c1 (ssadd c2)) "" "" "_non" ii "") t))
              (cmderr 621)
            )
          )
          (if (assoc 62 (setq ex (entget (entlast))))
            (setq ex (subst (cons 62 3) (assoc 62 ex) ex))
            (setq ex (append ex (list (cons 62 3))))
          )
          (entupd (cdr (assoc -1 (entmod ex))))
          (sssetfirst nil (ssadd (entlast)))
          (prompt "\nElapsed time : ") (prompt (ftoa (- (car (_vl-times)) ti))) (prompt " milliseconds...")
        )
        (prompt "\nInvalid curves relationship... Curves don't intersect in 2 distinct points...")
      )
    )
    (prompt "\nMissed, or picked entity not curve...")
  )
  (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
  (*error* nil)
)

 

Edited by marko_ribar
Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted

Ok, I see, another update... Should work now... I've tested it - watch now for input - picking of entities - must pick outside of meetings of curves...

 

Regards, M.R.

Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted

From you DWG : only upper blue polyline and magenata one below should work as there are only 2 intersecting points... Currently my routine doesn't support more than 2 int points, and beside be careful when picking polylines - you shouldn't pick at places where intersecting area is, but outer where open or closed curves have "so called - free endings"...

Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

Here I've made some improvements to overcome this issue with more int points... Also be careful with picking reference curves... And BTW., with SPLINES it won't perform reliably... So long, for now...

  

(defun c:2cur-int-cur ( / vl-load *error* cmdfun cmderr catch_cont apply_cadr->car ftoa reversecurve mid groupbynum sysvarpreset sysvarlst sysvarvals initvalueslst fuzz ti s1 c1 q1 s2 c2 q2 k ii e1 e2 ex ) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;;

  (defun vl-load nil
    (or cad
      (cond
        ( (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil)))
          (setq cad (vlax-get-acad-object))
        )
        ( t
          (vl-load-com)
          (setq cad (vlax-get-acad-object))
        )
      )
    )
    (or doc (setq doc (vla-get-activedocument cad)))
    (or alo (setq alo (vla-get-activelayout doc)))
    (or spc (setq spc (vla-get-block alo)))
  )

  ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
  (or (and cad doc alo spc) (vl-load))

  (defun *error* ( m )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if (not (cmdfun (list "_.UNDO" "_E") t))
        (cmderr 23)
        (if doc
          (vla-endundomark doc)
        )
      )
    )
    (if initvalueslst
      (mapcar (function apply_cadr->car) initvalueslst)
    )
    (if doc
      (vla-regen doc acactiveviewport)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun cmdfun ( tokenslist flag ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
    (if command-s
      (if flag
        (if (not (vl-catch-all-error-p (vl-catch-all-apply (function command-s) tokenslist)))
          flag
        )
        (apply (function command-s) tokenslist)
      )
      (if flag
        (apply (function vl-cmdf) tokenslist)
        (apply (function command) tokenslist)
      )
    )
  )

  (defun cmderr ( linenum ) ;;; linenum - integer representing line number at which used (cmdfun) failed with success execution ;;;
    (prompt (strcat "\ncommand execution failure... error at line " (itoa linenum) " ..."))
  )

  (defun catch_cont ( ctch / gr )
    (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
    (while
      (and
        (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
        (setq gr (grread))
        (/= (car gr) 3)
        (not (equal gr (list 2 13)))
      )
    )
    (if (vl-catch-all-error-p ctch)
      ctch
    )
  )

  (defun apply_cadr->car ( sysvarvaluepair / ctch )
    (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
    (if (vl-catch-all-error-p ctch)
      (progn
        (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
        (catch_cont ctch)
      )
    )
  )

  (defun ftoa ( n / m a s b )
    (if (numberp n)
      (progn
        (setq m (fix ((if (< n 0) - +) n 1e-8)))
        (setq a (abs (- n m)))
        (setq m (itoa m))
        (setq s "")
        (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
          (setq s (strcat s (itoa b)))
          (setq a (- (* a 10.0) b))
        )
        (if (= (type n) (quote int))
          m
          (if (= s "")
            m
            (if (and (= m "0") (< n 0))
              (strcat "-" m "." s)
              (strcat m "." s)
            )
          )
        )
      )
    )
  )

  (defun reversecurve ( curve / rlw r3dp rhpl rspl rhel rli rell rarc rci )

    (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
      ;; by ElpanovEvgeniy
      (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
        (progn
          (foreach a1 e
            (cond
              ( (= (car a1) 10) (setq x2 (cons a1 x2)) )
              ( (= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)) )
              ( (= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)) )
              ( (= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)) )
              ( (= (car a1) 210) (setq x6 (cons a1 x6)) )
              ( t (setq x1 (cons a1 x1)) )
            )
          )
          (entmod
            (append
              (reverse x1)
              (append
                (apply (function append)
                  (apply (function mapcar)
                    (cons (function list)
                      (list
                        x2
                        (cdr (reverse (cons (car x3) (reverse x3))))
                        (cdr (reverse (cons (car x4) (reverse x4))))
                        (cdr (reverse (cons (car x5) (reverse x5))))
                      )
                    )
                  )
                )
                x6
              )
            )
          )
          (entupd lw)
        )
      )
    )

    ;; Reverse HELIX - Marko Ribar, d.i.a.
    (defun rhel ( hel / enx enx1 enx2 v x1 x2 x3 )
      (if (= (cdr (assoc 0 (setq enx (entget hel)))) "HELIX")
        (progn
          (setq enx1 (reverse (cdr (member (cons 100 "AcDbHelix") (reverse enx)))) enx2 (member (cons 100 "AcDbHelix") enx))
          (foreach a1 enx1
            (cond
              ( (= (car a1) 40) (setq x2 (cons a1 x2)) )
              ( (= (car a1) 10) (setq x3 (cons a1 x3)) )
              ( t (setq x1 (cons a1 x1)) )
            )
          )
          (setq enx2 (subst (cons 40 (distance (cdr (assoc 10 enx2)) (cdr (assoc 11 enx2)))) (assoc 40 enx2) enx2) enx2 (subst (cons 10 (mapcar (function +) (cdr (assoc 10 enx2)) (mapcar (function *) (cdr (assoc 12 enx2)) (list (* (cdr (assoc 41 enx2)) (cdr (assoc 42 enx2))) (* (cdr (assoc 41 enx2)) (cdr (assoc 42 enx2))) (* (cdr (assoc 41 enx2)) (cdr (assoc 42 enx2))))))) (assoc 10 enx2) enx2) enx2 (subst (cons 11 (cdr (car x3))) (assoc 11 enx2) enx2) enx2 (subst (cons 12 (mapcar (function -) (cdr (assoc 12 enx2)))) (assoc 12 enx2) enx2))
          (entmod
            (append
              (reverse x1)
              (mapcar
                (function (lambda ( x )
                  (cons 40 (- (cdar x2) (cdr x)))
                ))
                x2
              )
              x3
              enx2
            )
          )
          (entupd hel)
        )
      )
    )

    ;; Reverse LINE - Marko Ribar, d.i.a.
    (defun rli ( li / enx sp ep )
      (if (= (cdr (assoc 0 (setq enx (entget li)))) "LINE")
        (progn
          (setq sp (cdr (assoc 10 enx)))
          (setq ep (cdr (assoc 11 enx)))
          (setq enx (subst (cons 10 ep) (assoc 10 enx) enx))
          (setq enx (subst (cons 11 sp) (assoc 11 enx) enx))
          (entmod enx)
          (entupd li)
        )
      )
    )

    ;; Reverse SPLINE - Marko Ribar, d.i.a.
    (defun rspl ( spl / enx x12 x13 x1 x2 x3 x4 x5 )
      (if (= (cdr (assoc 0 (setq enx (entget spl)))) "SPLINE")
        (progn
          (foreach a1 enx
            (cond
              ( (= (car a1) 12) (setq x13 (cons (cons 13 (mapcar (function -) (cdr a1))) x13)) )
              ( (= (car a1) 13) (setq x12 (cons (cons 12 (mapcar (function -) (cdr a1))) x12)) )
              ( (= (car a1) 40) (setq x2 (cons a1 x2)) )
              ( (= (car a1) 10) (setq x3 (cons a1 x3)) )
              ( (= (car a1) 41) (setq x4 (cons a1 x4)) )
              ( (= (car a1) 11) (setq x5 (cons a1 x5)) )
              ( t (setq x1 (cons a1 x1)) )
            )
          )
          (entmod
            (append
              (reverse x1)
              x12
              x13
              (mapcar
                (function (lambda ( x )
                  (cons 40 (- (cdar x2) (cdr x)))
                ))
                x2
              )
              (if x4
                (apply (function append)
                  (mapcar
                    (function (lambda ( a b )
                      (list a b)
                    ))
                    x3
                    x4
                  )
                )
                x3
              )
              x5
            )
          )
          (entupd spl)
        )
      )
    )

    ;; Reverse 3DPOLYLINE - Marko Ribar, d.i.a.
    (defun r3dp ( 3dp / r3dppol typ )

      (defun r3dppol ( 3dp / v p pl sfa var )
        (setq v 3dp)
        (while (= (cdr (assoc 0 (entget (setq v (entnext v))))) "VERTEX")
          (setq p (cdr (assoc 10 (entget v))) pl (cons p pl))
        )
        (setq pl (apply (function append) pl) sfa (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pl)))))
        (vlax-safearray-fill sfa pl)
        (setq var (vlax-make-variant sfa))
        (vla-put-coordinates (vlax-ename->vla-object 3dp) var)
        (entupd 3dp)
      )

      (setq typ (vla-get-type (vlax-ename->vla-object 3dp)))
      (vla-put-type (vlax-ename->vla-object 3dp) acsimplepoly)
      (r3dppol 3dp)
      (if typ (vla-put-type (vlax-ename->vla-object 3dp) typ))
      (entupd 3dp)
    )

    ;; Reverse old heavy 2d POLYLINE - Marko Ribar, d.i.a. - sub functions by Roy at Theswamp.org
    (defun rhpl ( hpl / KGA_List_Divide_3 KGA_List_IndexSeqMakeLength KGA_Geom_PolylineReverse )

      (defun KGA_List_Divide_3 ( lst / ret )
        (repeat (/ (length lst) 3)
          (setq ret (cons (list (car lst) (cadr lst) (caddr lst)) ret) lst (cdddr lst))
        )
        (reverse ret)
      )

      ; Make a zero based list of integers.
      (defun KGA_List_IndexSeqMakeLength ( len / ret )
        (repeat (rem len 4)
          (setq ret (cons (setq len (1- len)) ret))
        )
        (repeat (/ len 4)
          (setq ret (vl-list* (- len 4) (- len 3) (- len 2) (- len 1) ret) len (- len 4))
        )
        ret
      )

      ; Obj must be an "AcDb2dPolyline" of the acsimplepoly type or an "AcDbPolyline".
      (defun KGA_Geom_PolylineReverse ( obj / typ bulgeLst idxLst ptLst widLst conWid v vx )
        (setq typ (vla-get-type obj))
        (vla-put-type obj acsimplepoly)
        (setq ptLst (KGA_List_Divide_3 (vlax-get obj 'coordinates)) idxLst (KGA_List_IndexSeqMakeLength (1+ (length ptLst))) v (vlax-vla-object->ename obj))
        (while (= (cdr (assoc 0 (setq vx (entget (setq v (entnext v)))))) "VERTEX")
          (setq widLst (cons (list (cdr (assoc 40 vx)) (cdr (assoc 41 vx))) widLst) bulgeLst (cons (cdr (assoc 42 vx)) bulgeLst))
        )
        (if (vl-catch-all-error-p (setq conWid (vl-catch-all-apply (function vla-get-constantwidth) (list obj))))
          (mapcar
            (function (lambda ( idx pt bulge widSub )
              (vla-put-coordinate obj idx (vlax-3d-point pt))
              (vla-setbulge obj idx (- bulge))
              (vla-setwidth obj idx (cadr widSub) (car widSub))
            ))
            idxLst
            (reverse ptLst)
            (append
              (cdr bulgeLst)
              (list (car bulgeLst))
            )
            (append
              (cdr widLst)
              (list (car widLst))
            )
          )
          (progn
            (mapcar
              (function (lambda ( idx pt bulge widSub )
                (vla-put-coordinate obj idx (vlax-3d-point pt))
                (vla-setbulge obj idx (- bulge))
              ))
              idxLst
              (reverse ptLst)
              (append
                (cdr bulgeLst)
                (list (car bulgeLst))
              )
            )
            (vla-put-constantwidth obj conWid)
          )
        )
        (if typ (vla-put-type obj typ))
      )

      (KGA_Geom_PolylineReverse (vlax-ename->vla-object hpl))
      (entupd hpl)
    )

    (defun rell ( ell / ELL:point->param ellx ocs p1 p2 dxf dxf41 dxf42 )

      (defun ELL:point->param ( dxf pnt / ang ocs )
        (setq ocs (cdr (assoc 210 dxf))
              ang (- (angle (trans (cdr (assoc 10 dxf)) 0 ocs) (trans pnt 0 ocs))
                     (angle (list 0.0 0.0) (trans (cdr (assoc 11 dxf)) 0 ocs))
                  )
        )
        (atan (sin ang) (* (cdr (assoc 40 dxf)) (cos ang)))
      )

      (setq ellx (entget ell))
      (setq ocs (cdr (assoc 210 ellx)))
      (setq p1 (vlax-curve-getstartpoint ell) p2 (vlax-curve-getendpoint ell))
      (setq dxf (list (assoc 10 ellx) (cons 11 (mapcar (function -) (cdr (assoc 11 ellx)))) (assoc 40 ellx) (cons 210 (mapcar (function -) ocs))))
      (if (and (equal p1 (mapcar (function +) (cdr (assoc 10 ellx)) (cdr (assoc 11 ellx))) 1e-6) (equal p2 (mapcar (function +) (cdr (assoc 10 ellx)) (cdr (assoc 11 ellx))) 1e-6))
        (setq dxf41 0.0 dxf42 (* 2 pi))
        (setq dxf41 (ELL:point->param dxf p2) dxf42 (ELL:point->param dxf p1))
      )
      (setq ellx (subst (cons 11 (mapcar (function -) (cdr (assoc 11 ellx)))) (assoc 11 ellx) ellx))
      (setq ellx (subst (cons 41 dxf41) (assoc 41 ellx) ellx))
      (setq ellx (subst (cons 42 dxf42) (assoc 42 ellx) ellx))
      (setq ellx (subst (cons 210 (mapcar (function -) ocs)) (assoc 210 ellx) ellx))
      (entupd (cdr (assoc -1 (entmod ellx))))
    )

    (defun rarc ( arc / arcx cw ocs dxf50 dxf51 )
      (setq arcx (entget arc))
      (setq cw (trans (cdr (assoc 10 arcx)) arc 0))
      (setq ocs (cdr (assoc 210 arcx)))
      (setq dxf50 (cdr (assoc 50 arcx)) dxf51 (cdr (assoc 51 arcx)))
      (setq arcx (subst (cons 50 (- pi dxf51)) (assoc 50 arcx) arcx))
      (setq arcx (subst (cons 51 (- pi dxf50)) (assoc 51 arcx) arcx))
      (setq arcx (subst (cons 10 (trans cw 0 (mapcar (function -) ocs))) (assoc 10 arcx) arcx))
      (setq arcx (subst (cons 210 (mapcar (function -) ocs)) (assoc 210 arcx) arcx))
      (entupd (cdr (assoc -1 (entmod arcx))))
    )

    (defun rci ( ci / cix cw ocs )
      (setq cix (entget ci))
      (setq cw (trans (cdr (assoc 10 cix)) ci 0))
      (setq ocs (cdr (assoc 210 cix)))
      (setq cix (subst (cons 10 (trans cw 0 (mapcar (function -) ocs))) (assoc 10 cix) cix))
      (setq cix (subst (cons 210 (mapcar (function -) ocs)) (assoc 210 cix) cix))
      (entupd (cdr (assoc -1 (entmod cix))))
    )

    (cond
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbLine") (rli curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbHelix") (rhel curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDb2dPolyline") (rhpl curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDb3dPolyline") (r3dp curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbPolyline") (rlw curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbSpline") (rspl curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbEllipse") (rell curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbArc") (rarc curve) )
      ( (= (cdr (assoc 100 (reverse (entget curve)))) "AcDbCircle") (rci curve) )
    )
  )

  (defun mid ( p1 p2 )
    (mapcar
      (function (lambda ( a b )
        (/ (+ a b) 2.0)
      ))
      p1
      p2
    )
  )

  (defun groupbynum ( lst n / sub lll )

    (defun sub ( m n / ll q )
      (cond
        ( (and m (< (length m) n))
          (repeat (- n (length m))
            (setq m (append m (list nil)))
          )
          (setq ll (vl-remove-if-not (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m))
          (setq lll (cons ll lll))
          (setq q nil)
          (sub (vl-remove-if (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m) n)
        )
        ( m
          (setq ll (vl-remove-if-not (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m))
          (setq lll (cons ll lll))
          (setq q nil)
          (sub (vl-remove-if (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m) n)
        )
        ( t
          (reverse lll)
        )
      )
    )

    (sub lst n)
  )

  (setq sysvarpreset
    (list
      (list (quote cmdecho) 0)
      (list (quote 3dosmode) 0)
      (list (quote osmode) 0)
      (list (quote unitmode) 0)
      (list (quote cmddia) 0)
      (list (quote ucsvp) 0)
      (list (quote ucsortho) 0)
      (list (quote projmode) 0)
      (list (quote orbitautotarget) 0)
      (list (quote insunits) 0)
      (list (quote hpseparate) 0)
      (list (quote hpgaptol) 0)
      (list (quote halogap) 0)
      (list (quote edgemode) 0)
      (list (quote pickdrag) 0)
      (list (quote qtextmode) 0)
      (list (quote dragsnap) 0)
      (list (quote angdir) 0)
      (list (quote aunits) 0)
      (list (quote limcheck) 0)
      (list (quote gridmode) 0)
      (list (quote nomutt) 0)
      (list (quote apbox) 0)
      (list (quote attdia) 0)
      (list (quote blipmode) 0)
      (list (quote copymode) 0)
      (list (quote circlerad) 0.0)
      (list (quote filletrad) 0.0)
      (list (quote filedia) 1)
      (list (quote autosnap) 1)
      (list (quote objectisolationmode) 1)
      (list (quote highlight) 1)
      (list (quote lispinit) 1)
      (list (quote layerpmode) 1)
      (list (quote fillmode) 1)
      (list (quote dragmodeinterrupt) 1)
      (list (quote dispsilh) 1)
      (list (quote fielddisplay) 1)
      (list (quote deletetool) 1)
      (list (quote delobj) 1)
      (list (quote dblclkedit) 1)
      (list (quote attreq) 1)
      (list (quote explmode) 1)
      (list (quote frameselection) 1)
      (list (quote ltgapselection) 1)
      (list (quote pickfirst) 1)
      (list (quote plinegen) 1)
      (list (quote plinetype) 1)
      (list (quote peditaccept) 1)
      (list (quote solidcheck) 1)
      (list (quote visretain) 1)
      (list (quote regenmode) 1)
      (list (quote celtscale) 1.0)
      (list (quote ltscale) 1.0)
      (list (quote osnapcoord) 2)
      (list (quote grips) 2)
      (list (quote dragmode) 2)
      (list (quote lunits) 2)
      (list (quote pickstyle) 3)
      (list (quote navvcubedisplay) 3)
      (list (quote pickauto) 3)
      (list (quote draworderctl) 3)
      (list (quote expert) 5)
      (list (quote auprec) 6)
      (list (quote luprec) 6)
      (list (quote pickbox) 6)
      (list (quote aperture) 6)
      (list (quote osoptions) 7)
      (list (quote dimzin) 8)
      (list (quote pdmode) 35)
      (list (quote pdsize) -1.5)
      (list (quote celweight) -1)
      (list (quote cecolor) "BYLAYER")
      (list (quote celtype) "ByLayer")
      (list (quote clayer) "0")
    )
  )
  (setq sysvarlst (mapcar (function car) sysvarpreset))
  (setq sysvarvals (mapcar (function cadr) sysvarpreset))
  (setq sysvarvals
    (vl-remove nil
      (mapcar
        (function (lambda ( x )
          (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
        ))
        sysvarlst
      )
    )
  )
  (setq sysvarlst
    (vl-remove-if-not
      (function (lambda ( x )
        (getvar x)
      ))
      sysvarlst
    )
  )
  (setq initvalueslst
    (apply (function mapcar)
      (cons (function list)
        (list
          sysvarlst
          (mapcar (function getvar) sysvarlst)
        )
      )
    )
  )
  (apply (function mapcar)
    (cons (function setvar)
      (list
        sysvarlst
        sysvarvals
      )
    )
  )
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (if (not (cmdfun (list "_.UNDO" "_E") t))
      (cmderr 551)
      (if doc
        (vla-endundomark doc)
      )
    )
  )
  (if (not (cmdfun (list "_.UNDO" "_M") t))
    (cmderr 558)
    (if doc
      (vla-startundomark doc)
    )
  )
  (initget 6)
  (setq fuzz
    (cond
      ( (getreal "\nSpecify fuzz distance value per intersecting points advancing segment check <0.25> : ") )
      (0.25)
    )
  )
  (if
    (and
      (setq s1 (entsel "\nPick first curve from the outter side of intermeeting..."))
      (setq c1 (car s1))
      (setq q1 (cadr s1))
      (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-curve-getstartpoint) (list c1))))
      (setq s2 (entsel "\nPick second curve from the outter side of intermeeting..."))
      (setq c2 (car s2))
      (setq q2 (cadr s2))
      (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-curve-getstartpoint) (list c2))))
    )
    (progn
      (setq ti (car (_vl-times)))
      (if
        (and
          (setq ii (vlax-invoke (vlax-ename->vla-object c1) (quote intersectwith) (vlax-ename->vla-object c2) acextendnone))
          (setq ii (groupbynum ii 3))
          (vl-every (function (lambda ( a b ) (not (equal a b 1e-6)))) ii (cdr ii))
        )
        (progn
          (setq k 0)
          (setq q1 (trans (osnap q1 "_nea") 1 0))
          (setq q2 (trans (osnap q2 "_nea") 1 0))
          (if (not (cmdfun (list "_.BREAK" c1 "_non" (trans q1 0 1) "_non" (trans (vlax-curve-getpointatparam c1 (+ 0.05 (vlax-curve-getparamatpoint c1 q1))) 0 1)) t))
            (cmderr 594)
            (setq k (1+ k))
          )
          (setq s1 (ssadd))
          (if (not (vlax-erased-p c1))
            (progn
              (setq e1 c1)
              (setq e2 (entlast))
            )
            (progn
              (setq e2 (entlast))
              (entdel e2)
              (setq e1 (entlast))
              (entdel e2)
            )
          )
          (ssadd e1 s1)
          (ssadd e2 s1)
          (if (not (cmdfun (list "_.JOIN" s1 "") t))
            (cmderr 613)
            (setq k (1+ k))
          )
          (cond
            (
              (and
                (not (vlax-erased-p e1))
                (not (vlax-erased-p e2))
                (equal (car ii) (vlax-curve-getclosestpointto e1 (car ii)) 1e-3)
              )
              (setq c1 e1)
            )
            (
              (and
                (not (vlax-erased-p e1))
                (not (vlax-erased-p e2))
                (equal (car ii) (vlax-curve-getclosestpointto e2 (car ii)) 1e-3)
              )
              (setq c1 e2)
            )
            (
              (and
                (not (vlax-erased-p e1))
                (vlax-erased-p e2)
                (equal (car ii) (vlax-curve-getclosestpointto e1 (car ii)) 1e-3)
              )
              (setq c1 e1)
            )
            (
              (and
                (vlax-erased-p e1)
                (not (vlax-erased-p e2))
                (equal (car ii) (vlax-curve-getclosestpointto e2 (car ii)) 1e-3)
              )
              (setq c1 e2)
            )
            ( (equal (car ii) (vlax-curve-getclosestpointto (entlast) (car ii)) 1e-3)
              (setq c1 (entlast))
            )
          )
          (if (not (cmdfun (list "_.BREAK" c2 "_non" (trans q2 0 1) "_non" (trans (vlax-curve-getpointatparam c2 (+ 0.05 (vlax-curve-getparamatpoint c2 q2))) 0 1)) t))
            (cmderr 654)
            (setq k (1+ k))
          )
          (setq s2 (ssadd))
          (if (not (vlax-erased-p c2))
            (progn
              (setq e1 c2)
              (setq e2 (entlast))
            )
            (progn
              (setq e2 (entlast))
              (entdel e2)
              (setq e1 (entlast))
              (entdel e2)
            )
          )
          (ssadd e1 s2)
          (ssadd e2 s2)
          (if (not (cmdfun (list "_.JOIN" s2 "") t))
            (cmderr 673)
            (setq k (1+ k))
          )
          (cond
            (
              (and
                (not (vlax-erased-p e1))
                (not (vlax-erased-p e2))
                (equal (car ii) (vlax-curve-getclosestpointto e1 (car ii)) 1e-3)
              )
              (setq c2 e1)
            )
            (
              (and
                (not (vlax-erased-p e1))
                (not (vlax-erased-p e2))
                (equal (car ii) (vlax-curve-getclosestpointto e2 (car ii)) 1e-3)
              )
              (setq c2 e2)
            )
            (
              (and
                (not (vlax-erased-p e1))
                (vlax-erased-p e2)
                (equal (car ii) (vlax-curve-getclosestpointto e1 (car ii)) 1e-3)
              )
              (setq c2 e1)
            )
            (
              (and
                (vlax-erased-p e1)
                (not (vlax-erased-p e2))
                (equal (car ii) (vlax-curve-getclosestpointto e2 (car ii)) 1e-3)
              )
              (setq c2 e2)
            )
            ( (equal (car ii) (vlax-curve-getclosestpointto (entlast) (car ii)) 1e-3)
              (setq c2 (entlast))
            )
          )
          (if (> (vlax-curve-getparamatpoint c1 (car ii)) (vlax-curve-getparamatpoint c1 (cadr ii)))
            (setq c1 (reversecurve c1))
          )
          (if (> (vlax-curve-getparamatpoint c2 (car ii)) (vlax-curve-getparamatpoint c2 (cadr ii)))
            (setq c2 (reversecurve c2))
          )
          (setq ii
            (mapcar
              (function (lambda ( x )
                (trans
                  (mid
                    (vlax-curve-getpointatparam c1
                      (+
                        (-
                          (vlax-curve-getparamatdist c1
                            (+ fuzz (vlax-curve-getdistatpoint c1 x))
                          )
                          (vlax-curve-getparamatdist c1
                            (vlax-curve-getdistatpoint c1 x)
                          )
                        )
                        (vlax-curve-getparamatpoint c1 x)
                      )
                    )
                    (vlax-curve-getpointatparam c2
                      (+
                        (-
                          (vlax-curve-getparamatdist c2
                            (+ fuzz (vlax-curve-getdistatpoint c2 x))
                          )
                          (vlax-curve-getparamatdist c2
                            (vlax-curve-getdistatpoint c2 x)
                          )
                        )
                        (vlax-curve-getparamatpoint c2 x)
                      )
                    )
                  )
                  0
                  1
                )
              ))
              ii
            )
          )
          (if
            (not
              (and
                (/= k 0)
                (cmdfun (list "_.UNDO" k) t)
              )
            )
            (cmderr 765)
          )
          (foreach p ii
            (if (not (cmdfun (list "_.-BOUNDARY" "_A" "_O" "_P" "_I" "_Y" "_B" "_N" (ssadd c1 (ssadd c2)) "" "" "_non" p "") t))
              (if (not (cmdfun (list "_.-BOUNDARY" "_A" "_O" "_R" "_I" "_Y" "_B" "_N" (ssadd c1 (ssadd c2)) "" "" "_non" p "") t))
                (cmderr 770)
              )
            )
            (if (assoc 62 (setq ex (entget (entlast))))
              (setq ex (subst (cons 62 3) (assoc 62 ex) ex))
              (setq ex (append ex (list (cons 62 3))))
            )
            (entupd (cdr (assoc -1 (entmod ex))))
            (sssetfirst nil (ssadd (entlast)))
          )
          (prompt "\nElapsed time : ") (prompt (ftoa (- (car (_vl-times)) ti))) (prompt " milliseconds...")
          (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
        )
        (prompt "\nInvalid curves relationship... Curves don't intersect in 2 distinct points...")
      )
    )
    (prompt "\nMissed, or picked entity not curve...")
  )
  (*error* nil)
)

 

Edited by marko_ribar
  • Like 1
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...