Jump to content

INVERTED FILLET HELP..

leonucadomi

By leonucadomi
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

leonucadomi Rising Star

leonucadomi

Posted
Posted

IS THERE ANY WAY TO MAKE AN INVERTED FILLET?

ASK THE RADIO

SELECT BOTH LINES

 

AND WHAT IS DRAWN

 

I APPRECIATE YOUR COMMENTS

 

THANKS

 

 

 

image.thumb.png.c29e089f5f3a72c8f270eda7cde4e7b4.png

Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted (edited) 
(defun c:inv_fillet ( / *error* ftoa cmd rad r p pp pl ss i e el ex par flag k )

  (vl-load-com)

  (defun *error* ( m )
    (if command-s
      (command-s "_.UNDO" "_E")
      (vl-cmdf "_.UNDO" "_E")
    )
    (if cmd
      (setvar 'cmdecho cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (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) 'int)
          m
          (if (= s "")
            m
            (if (and (= m "0") (< n 0))
              (strcat "-" m "." s)
              (strcat m "." s)
            )
          )
        )
      )
    )
  )

  (setq cmd (getvar 'cmdecho))
  (setvar 'cmdecho 1)
  (if (= 8 (logand 8 (getvar 'undoctl)))
    (vl-cmdf "_.UNDO" "_E")
  )
  (vl-cmdf "_.UNDO" "_G")
  (setq rad (getvar 'filletrad))
  (initget 6)
  (setq r (getdist (strcat "\nPick or specify radius of fillet <" (ftoa rad) "> : ")))
  (if (not r)
    (setq r rad)
  )
  (setvar 'filletrad r)
  (prompt "\nENTER FOR PICK CURVES - 2 SEGMENTS, ELSE SELECT POLYLINES...")
  (if
    (if (ssget "_A" '((0 . "*POLYLINE")))
      (not (setq ss (ssget "_:L" '((0 . "*POLYLINE")))))
      t
    )
    (progn
      (setq p (getvar 'lastpoint) el (entlast))
      (vl-cmdf "_.FILLET")
      (while (< 0 (getvar 'cmdactive))
        (vl-cmdf "\\")
        (if (not (equal p (setq pp (getvar 'lastpoint)) 1e-6))
          (setq pl (cons pp pl))
        )
      )
      (if (not (eq el (entlast)))
        (if (= (cdr (assoc 0 (setq ex (entget (entlast))))) "ARC")
          (entupd (cdr (assoc -1 (entmod (mapcar (function (lambda ( x ) (cond ( (= (car x) 50) (cons 50 (cdr (assoc 51 ex))) ) ( (= (car x) 51) (cons 51 (cdr (assoc 50 ex))) ) ( t x )))) ex)))))
        )
        (if (wcmatch (cdr (assoc 0 (setq ex (entget (car (nentselp (osnap (car pl) "_nea"))))))) "*POLYLINE,VERTEX")
          (progn
            (if (wcmatch (cdr (assoc 0 ex)) "POLYLINE,VERTEX")
              (cond
                ( (= (cdr (assoc 0 ex)) "VERTEX")
                  (setq ex (entget (cdr (assoc 330 ex))))
                  (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
                  (setq ex (entget (cdr (assoc -1 ex))))
                  (setq flag t)
                )
                ( (= (cdr (assoc 0 ex)) "POLYLINE")
                  (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
                  (setq ex (entget (cdr (assoc -1 ex))))
                  (setq flag t)
                )
              )
            )
            (if (= (cdr (assoc 0 ex)) "LWPOLYLINE")
              (if (> (abs (fix (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl)))))) 1.0)
                (if (= (cdr (assoc 42 ex)) 0.0)
                  (entupd (cdr (assoc -1 (entmod (subst (cons 42 (- (/ 1.0 (cdr (assoc 42 (reverse ex)))))) (assoc 42 (reverse ex)) ex)))))
                  (entupd (cdr (assoc -1 (entmod (subst (cons 42 (- (/ 1.0 (cdr (assoc 42 ex))))) (assoc 42 ex) ex)))))
                )
                (progn
                  (setq par (/ (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl)))) 2.0))
                  (entupd (cdr (assoc -1 (entmod (mapcar (function (lambda ( x ) (if (= (car x) 42) (progn (setq k (if (not k) 0 (1+ k))) (if (= k (fix par)) (if (/= (cdr x) 0.0) (cons 42 (- (/ 1.0 (cdr x)))) (cons 42 0.0)) x)) x))) ex)))))
                )
              )
            )
            (if flag
              (vl-cmdf "_.CONVERTPOLY" "_H" (cdr (assoc -1 ex)) "")
            )
          )
        )
      )
    )
    (if ss
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (vl-cmdf "_.FILLET" "_P" e)
        (while (< 0 (getvar 'cmdactive))
          (vl-cmdf "")
        )
        (setq ex (entget e))
        (if (wcmatch (cdr (assoc 0 ex)) "POLYLINE,VERTEX")
          (cond
            ( (= (cdr (assoc 0 ex)) "VERTEX")
              (setq ex (entget (cdr (assoc 330 ex))))
              (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
              (setq ex (entget (cdr (assoc -1 ex))))
              (setq flag t)
            )
            ( (= (cdr (assoc 0 ex)) "POLYLINE")
              (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
              (setq ex (entget (cdr (assoc -1 ex))))
              (setq flag t)
            )
          )
        )
        (if (= (cdr (assoc 0 ex)) "LWPOLYLINE")
          (entupd (cdr (assoc -1 (entmod (mapcar (function (lambda ( x ) (if (and (= (car x) 42) (/= (cdr x) 0.0)) (cons 42 (- (/ 1.0 (cdr x)))) x))) ex)))))
        )
        (if flag
          (vl-cmdf "_.CONVERTPOLY" "_H" (cdr (assoc -1 ex)) "")
        )
        (setq flag nil)
      )
    )
  )
  (*error* nil)
)

 

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

BIGAL

Posted
Posted (edited)

Maybe draw circle at int of 2 lines then trim circle and lines, do TRIM then Window selection over the circle and lines, Enter, select 2 lines inside circle, then diagonal opposite corner to circle, ie remove outside. All done. No code needed. Yes could be coded.

 

 

 

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

marko_ribar

Posted
Posted (edited) 
(defun c:corner_chamfer_arc ( / *error* ftoa catch_cont unit mid v^v MR:3pcircle MR:3parc cmd pea rad r p pp pl c arc1 arc2 p1 p2 p3 p4 ss s i e el ex par flag flagg k ptl ptlpairs pair n )

  (vl-load-com)

  (defun *error* ( m )
    (if command-s
      (command-s "_.UNDO" "_E")
      (vl-cmdf "_.UNDO" "_E")
    )
    (if cmd
      (setvar 'cmdecho cmd)
    )
    (if pea
      (setvar 'peditaccept pea)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (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) 'int)
          m
          (if (= s "")
            m
            (if (and (= m "0") (< n 0))
              (strcat "-" m "." s)
              (strcat m "." s)
            )
          )
        )
      )
    )
  )

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

  (defun unit ( v / d )
    (if (not (equal (setq d (distance (list 0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar (function (lambda ( x ) (/ x d))) v)
      (progn
        (prompt "\ncatched error in (unit) - strength of reference vector near 0.0")
        (if (vl-catch-all-error-p (catch_cont))
          (vl-catch-all-apply (function /) (list 1 0))
        )
      )
    )
  )

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

  (defun v^v ( u v )
    (list
      (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
      (- (* (caddr u) (car v)) (* (car u) (caddr v)))
      (- (* (car u) (cadr v)) (* (cadr u) (car v)))
    )
  )

  ;; 3-Point Circle  -  M.R. ;;
  ;; Returns the center (WCS) and radius of the circle defined by three supplied points - all 3 points in (WCS) ;;

  (defun MR:3pcircle ( pt1 pt2 pt3 / cen md1 md2 vc1 vc2 ocs ci )
    (if
      (and
        (setq md1 (mid pt1 pt2))
        (setq md2 (mid pt2 pt3))
        (setq vc1 (v^v (mapcar (function -) pt2 pt1) (setq ocs (v^v (mapcar (function -) pt3 pt1) (mapcar (function -) pt2 pt1)))))
        (setq vc2 (v^v (mapcar (function -) pt3 pt2) ocs))
        (setq cen (inters
                    md1 (mapcar (function +) md1 vc1)
                    md2 (mapcar (function +) md2 vc2)
                    nil
                  )
        )
      )
      (list cen (distance cen pt1))
    )
  )

  ;; 3-Point Arc  -  M.R. ;;
  ;; Returns ARC entity in 3D space - arguments pt1, pt2, pt3 - all 3 points in (WCS) ;;

  (defun MR:3parc ( pt1 pt2 pt3 / lst ocs )
    (if (and (setq ocs (unit (v^v (mapcar (function -) pt3 pt1) (mapcar (function -) pt2 pt1)))) (setq lst (MR:3pcircle pt1 pt2 pt3)))
      (progn
        (if (minusp (sin (- (angle (trans pt1 0 ocs) (trans pt3 0 ocs)) (angle (trans pt1 0 ocs) (trans pt2 0 ocs)))))
          (mapcar (function set) (list (quote pt1) (quote pt3)) (list pt3 pt1))
        )
        (entmakex
          (list
            (cons 0 "ARC")
            (cons 10 (trans (car lst) 0 ocs))
            (cons 40 (cadr lst))
            (cons 50 (angle (trans (car lst) 0 ocs) (trans pt1 0 ocs)))
            (cons 51 (angle (trans (car lst) 0 ocs) (trans pt3 0 ocs)))
            (cons 210 ocs)
          )
        )
      )
    )
  )

  (setq cmd (getvar 'cmdecho))
  (setvar 'cmdecho 1)
  (setq pea (getvar 'peditaccept))
  (setvar 'peditaccept 1)
  (if (= 8 (logand 8 (getvar 'undoctl)))
    (vl-cmdf "_.UNDO" "_E")
  )
  (vl-cmdf "_.UNDO" "_G")
  (setq rad (getvar 'filletrad))
  (initget 6)
  (setq r (getdist (strcat "\nPick or specify radius of fillet <" (ftoa rad) "> : ")))
  (if (not r)
    (setq r rad)
  )
  (setvar 'chamfera r)
  (setvar 'chamferb r)
  (prompt "\nENTER FOR PICK CURVES - 2 SEGMENTS, ELSE SELECT POLYLINES...")
  (if
    (if (ssget "_A" '((0 . "*POLYLINE")))
      (not (setq ss (ssget "_:L" '((0 . "*POLYLINE")))))
      t
    )
    (progn
      (setq p (getvar 'lastpoint) el (entlast))
      (vl-cmdf "_.CHAMFER")
      (while (< 0 (getvar 'cmdactive))
        (vl-cmdf "\\")
        (if (not (equal p (setq pp (getvar 'lastpoint)) 1e-6))
          (setq pl (cons pp pl))
        )
      )
      (if (not (eq el (entlast)))
        (if (= (cdr (assoc 0 (setq ex (entget (entlast))))) "LINE")
          (progn
            (setq c (inters (vlax-curve-getpointatparam (setq e (car (nentselp (osnap (car pl) "_nea")))) (- (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e (car pl))) 0.05)) (vlax-curve-getpointatparam (setq e (car (nentselp (osnap (car pl) "_nea")))) (+ (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e (car pl))) 0.05)) (vlax-curve-getpointatparam (setq e (car (nentselp (osnap (cadr pl) "_nea")))) (- (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e (cadr pl))) 0.05)) (vlax-curve-getpointatparam (setq e (car (nentselp (osnap (cadr pl) "_nea")))) (+ (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e (cadr pl))) 0.05)) nil))
            (setq arc1 (MR:3parc (cdr (assoc 10 ex)) (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) (mid (cdr (assoc 10 ex)) (cdr (assoc 11 ex))) c)) (list r r r)) c) (cdr (assoc 11 ex))))
            (setq arc2 (MR:3parc (cdr (assoc 10 ex)) (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) c (mid (cdr (assoc 10 ex)) (cdr (assoc 11 ex))))) (list r r r)) c) (cdr (assoc 11 ex))))
            (if (< (vla-get-arclength (vlax-ename->vla-object arc1)) (vla-get-arclength (vlax-ename->vla-object arc2)))
              (entdel arc2)
              (entdel arc1)
            )
            (entdel (cdr (assoc -1 ex)))
          )
        )
        (if (wcmatch (cdr (assoc 0 (setq ex (entget (car (nentselp (osnap (car pl) "_nea"))))))) "*POLYLINE,VERTEX")
          (progn
            (if (wcmatch (cdr (assoc 0 ex)) "POLYLINE,VERTEX")
              (cond
                ( (= (cdr (assoc 0 ex)) "VERTEX")
                  (setq ex (entget (cdr (assoc 330 ex))))
                  (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
                  (setq ex (entget (cdr (assoc -1 ex))))
                  (setq flag 1)
                )
                ( (= (cdr (assoc 0 ex)) "POLYLINE")
                  (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
                  (setq ex (entget (cdr (assoc -1 ex))))
                  (setq flag 1)
                )
              )
            )
            (if (= (cdr (assoc 0 ex)) "LWPOLYLINE")
              (if (> (abs (fix (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl)))))) 1.0)
                (progn
                  (setq c (inters (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl))) 0.05)) nil))
                  (setq arc1 (MR:3parc (vlax-curve-getstartpoint (cdr (assoc -1 ex))) (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) (mid (vlax-curve-getstartpoint (cdr (assoc -1 ex))) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (1- (vlax-curve-getendparam (cdr (assoc -1 ex)))))) c)) (list r r r)) c) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (1- (vlax-curve-getendparam (cdr (assoc -1 ex)))))))
                  (setq arc2 (MR:3parc (vlax-curve-getstartpoint (cdr (assoc -1 ex))) (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) c (mid (vlax-curve-getstartpoint (cdr (assoc -1 ex))) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (1- (vlax-curve-getendparam (cdr (assoc -1 ex)))))))) (list r r r)) c) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (1- (vlax-curve-getendparam (cdr (assoc -1 ex)))))))
                  (if (< (vla-get-arclength (vlax-ename->vla-object arc1)) (vla-get-arclength (vlax-ename->vla-object arc2)))
                    (entdel arc2)
                    (entdel arc1)
                  )
                  (entupd (cdr (assoc -1 (entmod (subst (cons 70 (* 128 (getvar 'plinegen))) (assoc 70 ex) ex)))))
                  (setq s (ssadd))
                  (cond
                    ( (not (vlax-erased-p arc1))
                      (ssadd arc1 s)
                    )
                    ( (not (vlax-erased-p arc2))
                      (ssadd arc2 s)
                    )
                  )
                  (ssadd (cdr (assoc -1 ex)) s)
                  ;|
                  (vl-cmdf "_.PEDIT" "_M" s "" "_J")
                  (while (< 0 (getvar 'cmdactive))
                    (vl-cmdf "")
                  )
                  |; ;;; for AutoCAD
                  (vl-cmdf "_.JOIN" s "") ;;; for BricsCAD
                )
                (progn
                  (setq par (- (max (fix (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl)))) (fix (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl))))) 0.5))
                  (setq p1 (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- par 0.5)) p2 (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ par 0.5)))
                  (setq c (inters (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl))) 0.05)) nil))
                  (setq arc1 (MR:3parc p1 (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) (mid p1 p2) c)) (list r r r)) c) p2))
                  (setq arc2 (MR:3parc p1 (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) c (mid p1 p2))) (list r r r)) c) p2))
                  (if (< (vla-get-arclength (vlax-ename->vla-object arc1)) (vla-get-arclength (vlax-ename->vla-object arc2)))
                    (entdel arc2)
                    (entdel arc1)
                  )
                  (vl-cmdf "_.BREAK" (cdr (assoc -1 ex)) "" "_non" (trans p1 0 1) "_non" (trans p2 0 1))
                  (setq s (ssadd))
                  (cond
                    ( (not (vlax-erased-p arc1))
                      (ssadd arc1 s)
                    )
                    ( (not (vlax-erased-p arc2))
                      (ssadd arc2 s)
                    )
                  )
                  (ssadd (car (nentselp (osnap (cadr pl) "_nea"))) s)
                  (ssadd (car (nentselp (osnap (car pl) "_nea"))) s)
                  ;|
                  (vl-cmdf "_.PEDIT" "_M" s "" "_J")
                  (while (< 0 (getvar 'cmdactive))
                    (vl-cmdf "")
                  )
                  |; ;;; for AutoCAD
                  (vl-cmdf "_.JOIN" s "") ;;; for BricsCAD
                )
              )
            )
            (if flag
              (vl-cmdf "_.CONVERTPOLY" "_H" (cdr (assoc -1 ex)) "")
            )
          )
        )
      )
    )
    (if ss
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (setq ex (entget e))
        (if (wcmatch (cdr (assoc 0 ex)) "POLYLINE,VERTEX")
          (cond
            ( (= (cdr (assoc 0 ex)) "VERTEX")
              (setq ex (entget (cdr (assoc 330 ex))))
              (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
              (setq ex (entget (cdr (assoc -1 ex))))
              (setq flag 1)
            )
            ( (= (cdr (assoc 0 ex)) "POLYLINE")
              (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
              (setq ex (entget (cdr (assoc -1 ex))))
              (setq flag 1)
            )
          )
        )
        (if (= 1 (logand 1 (cdr (assoc 70 (setq ex (entget e))))))
          (progn
            (setq ptl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) ex)))
            (setq ptlpairs (mapcar (function (lambda ( a b ) (list a b))) ptl (append (cdr ptl) (list (car ptl)))))
            (setq pair (car (vl-sort ptlpairs (function (lambda ( a b ) (> (distance (car a) (cadr a)) (distance (car b) (cadr b))))))))
            (setq flagg 1)
            (vl-cmdf "_.BREAK" e "" "_non" (trans (polar (mid (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (car pair) (list (cdr (assoc 38 ex)))) e 0)))))) (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (cadr pair) (list (cdr (assoc 38 ex)))) e 0))))))) (angle (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (car pair) (list (cdr (assoc 38 ex)))) e 0)))))) (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (cadr pair) (list (cdr (assoc 38 ex)))) e 0))))))) 0.05) 0 1) "_non" (trans (polar (mid (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (car pair) (list (cdr (assoc 38 ex)))) e 0)))))) (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (cadr pair) (list (cdr (assoc 38 ex)))) e 0))))))) (angle (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (car pair) (list (cdr (assoc 38 ex)))) e 0)))))) (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (cadr pair) (list (cdr (assoc 38 ex)))) e 0))))))) -0.05) 0 1))
          )
        )
        (vl-cmdf "_.CHAMFER" "_P" e)
        (while (< 0 (getvar 'cmdactive))
          (vl-cmdf "")
        )
        (setq ex (entget e))
        (repeat (fix (/ (+ 0.1 (setq n (1- (vlax-curve-getendparam (cdr (assoc -1 ex)))))) 2.0))
          (setq par (+ (setq n (- n 2.0)) 1.5))
          (setq p1 (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (rem (- par 0.5) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))) p2 (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (rem (+ par 0.5) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))))
          (setq c (inters (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1- par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1- par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1+ par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1+ par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))))) 0.05)) nil))
          (setq arc1 (MR:3parc p1 (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) (mid p1 p2) c)) (list r r r)) c) p2))
          (setq arc2 (MR:3parc p1 (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) c (mid p1 p2))) (list r r r)) c) p2))
          (if (< (vla-get-arclength (vlax-ename->vla-object arc1)) (vla-get-arclength (vlax-ename->vla-object arc2)))
            (entdel arc2)
            (entdel arc1)
          )
          (setq p3 (trans (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1- par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex)))))))) 0 1) p4 (trans (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1+ par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex)))))))) 0 1))
          (vl-cmdf "_.BREAK" (cdr (assoc -1 ex)) "" "_non" (trans p1 0 1) "_non" (trans p2 0 1))
          (setq s (ssadd))
          (cond
            ( (not (vlax-erased-p arc1))
              (ssadd arc1 s)
            )
            ( (not (vlax-erased-p arc2))
              (ssadd arc2 s)
            )
          )
          (ssadd (car (nentselp p3)) s)
          (ssadd (car (nentselp p4)) s)
          ;|
          (vl-cmdf "_.PEDIT" "_M" s "" "_J")
          (while (< 0 (getvar 'cmdactive))
            (vl-cmdf "")
          )
          |; ;;; for AutoCAD
          (vl-cmdf "_.JOIN" s "") ;;; for BricsCAD
        )
        (if flagg
          (progn
            ;|
            (if (not (eq (cdr (assoc -1 ex)) (entlast)))
              (setq ex (entget (entlast)))
            )
            (setq n (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))
            (setq ex (mapcar (function (lambda ( x ) (if (= (car x) 10) (progn (setq k (if (not k) 0 (1+ k))) (if (or (= k 0) (= k n)) 1 x)) x))) ex))
            (setq k nil)
            (setq ex (append (reverse (cdr (member 1 (cdr (member 1 (reverse ex)))))) (member (assoc 10 (cdr (member 1 ex))) (reverse (cdr (member 1 (reverse ex))))) (cdr (member 1 (cdr (member 1 ex))))))
            (setq ex (subst (cons 90 (1- n)) (assoc 90 ex) ex))
            (setq ex (subst (cons 70 (1+ (* 128 (getvar 'plinegen)))) (assoc 70 ex) ex))
            (entupd (cdr (assoc -1 (entmod ex))))
            |; ; something's wrong with this version - try to debug if you want ;

            (vl-cmdf "_.TRIM" "_L" "" "_non" (trans (vlax-curve-getstartpoint (entlast)) 0 1) "_non" (trans (vlax-curve-getendpoint (entlast)) 0 1) "")
            (vla-put-closed (vlax-ename->vla-object (entlast)) :vlax-true)
  
          )
        )
        (if flag
          (vl-cmdf "_.CONVERTPOLY" "_H" (cdr (assoc -1 ex)) "")
        )
        (setq flag nil flagg nil)
      )
    )
  )
  (*error* nil)
)

 

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

marko_ribar

Posted
Posted (edited) 
(defun c:corner_inv_chamfer_arc ( / *error* ftoa catch_cont unit mid v^v MR:3pcircle MR:3parc cmd pea rad r p pp pl c arc1 arc2 p1 p2 p3 p4 ss s i e el ex par flag flagg k ptl ptlpairs pair n )

  (vl-load-com)

  (defun *error* ( m )
    (if command-s
      (command-s "_.UNDO" "_E")
      (vl-cmdf "_.UNDO" "_E")
    )
    (if cmd
      (setvar 'cmdecho cmd)
    )
    (if pea
      (setvar 'peditaccept pea)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (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) 'int)
          m
          (if (= s "")
            m
            (if (and (= m "0") (< n 0))
              (strcat "-" m "." s)
              (strcat m "." s)
            )
          )
        )
      )
    )
  )

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

  (defun unit ( v / d catch )
    (if (not (equal (setq d (distance (list 0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar (function (lambda ( x ) (/ x d))) v)
      (progn
        (prompt "\ncatched error in (unit) - strength of reference vector near 0.0")
        (if (vl-catch-all-error-p (catch_cont))
          (vl-catch-all-apply (function /) (list 1 0))
        )
      )
    )
  )

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

  (defun v^v ( u v )
    (list
      (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
      (- (* (caddr u) (car v)) (* (car u) (caddr v)))
      (- (* (car u) (cadr v)) (* (cadr u) (car v)))
    )
  )

  ;; 3-Point Circle  -  M.R. ;;
  ;; Returns the center (WCS) and radius of the circle defined by three supplied points - all 3 points in (WCS) ;;

  (defun MR:3pcircle ( pt1 pt2 pt3 / cen md1 md2 vc1 vc2 ocs ci )
    (if
      (and
        (setq md1 (mid pt1 pt2))
        (setq md2 (mid pt2 pt3))
        (setq vc1 (v^v (mapcar (function -) pt2 pt1) (setq ocs (v^v (mapcar (function -) pt3 pt1) (mapcar (function -) pt2 pt1)))))
        (setq vc2 (v^v (mapcar (function -) pt3 pt2) ocs))
        (setq cen (inters
                    md1 (mapcar (function +) md1 vc1)
                    md2 (mapcar (function +) md2 vc2)
                    nil
                  )
        )
      )
      (list cen (distance cen pt1))
    )
  )

  ;; 3-Point Arc  -  M.R. ;;
  ;; Returns ARC entity in 3D space - arguments pt1, pt2, pt3 - all 3 points in (WCS) ;;

  (defun MR:3parc ( pt1 pt2 pt3 / lst ocs )
    (if (and (setq ocs (unit (v^v (mapcar (function -) pt3 pt1) (mapcar (function -) pt2 pt1)))) (setq lst (MR:3pcircle pt1 pt2 pt3)))
      (progn
        (if (minusp (sin (- (angle (trans pt1 0 ocs) (trans pt3 0 ocs)) (angle (trans pt1 0 ocs) (trans pt2 0 ocs)))))
          (mapcar (function set) (list (quote pt1) (quote pt3)) (list pt3 pt1))
        )
        (entmakex
          (list
            (cons 0 "ARC")
            (cons 10 (trans (car lst) 0 ocs))
            (cons 40 (cadr lst))
            (cons 50 (angle (trans (car lst) 0 ocs) (trans pt1 0 ocs)))
            (cons 51 (angle (trans (car lst) 0 ocs) (trans pt3 0 ocs)))
            (cons 210 ocs)
          )
        )
      )
    )
  )

  (setq cmd (getvar 'cmdecho))
  (setvar 'cmdecho 1)
  (setq pea (getvar 'peditaccept))
  (setvar 'peditaccept 1)
  (if (= 8 (logand 8 (getvar 'undoctl)))
    (vl-cmdf "_.UNDO" "_E")
  )
  (vl-cmdf "_.UNDO" "_G")
  (setq rad (getvar 'filletrad))
  (initget 6)
  (setq r (getdist (strcat "\nPick or specify radius of fillet <" (ftoa rad) "> : ")))
  (if (not r)
    (setq r rad)
  )
  (setvar 'chamfera r)
  (setvar 'chamferb r)
  (prompt "\nENTER FOR PICK CURVES - 2 SEGMENTS, ELSE SELECT POLYLINES...")
  (if
    (if (ssget "_A" '((0 . "*POLYLINE")))
      (not (setq ss (ssget "_:L" '((0 . "*POLYLINE")))))
      t
    )
    (progn
      (setq p (getvar 'lastpoint) el (entlast))
      (vl-cmdf "_.CHAMFER")
      (while (< 0 (getvar 'cmdactive))
        (vl-cmdf "\\")
        (if (not (equal p (setq pp (getvar 'lastpoint)) 1e-6))
          (setq pl (cons pp pl))
        )
      )
      (if (not (eq el (entlast)))
        (if (= (cdr (assoc 0 (setq ex (entget (entlast))))) "LINE")
          (progn
            (setq c (inters (vlax-curve-getpointatparam (setq e (car (nentselp (osnap (car pl) "_nea")))) (- (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e (car pl))) 0.05)) (vlax-curve-getpointatparam (setq e (car (nentselp (osnap (car pl) "_nea")))) (+ (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e (car pl))) 0.05)) (vlax-curve-getpointatparam (setq e (car (nentselp (osnap (cadr pl) "_nea")))) (- (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e (cadr pl))) 0.05)) (vlax-curve-getpointatparam (setq e (car (nentselp (osnap (cadr pl) "_nea")))) (+ (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e (cadr pl))) 0.05)) nil))
            (setq arc1 (MR:3parc (cdr (assoc 10 ex)) (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) (mid (cdr (assoc 10 ex)) (cdr (assoc 11 ex))) c)) (list r r r)) c) (cdr (assoc 11 ex))))
            (setq arc2 (MR:3parc (cdr (assoc 10 ex)) (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) c (mid (cdr (assoc 10 ex)) (cdr (assoc 11 ex))))) (list r r r)) c) (cdr (assoc 11 ex))))
            (if (< (vla-get-arclength (vlax-ename->vla-object arc1)) (vla-get-arclength (vlax-ename->vla-object arc2)))
              (entdel arc1)
              (entdel arc2)
            )
            (entdel (cdr (assoc -1 ex)))
          )
        )
        (if (wcmatch (cdr (assoc 0 (setq ex (entget (car (nentselp (osnap (car pl) "_nea"))))))) "*POLYLINE,VERTEX")
          (progn
            (if (wcmatch (cdr (assoc 0 ex)) "POLYLINE,VERTEX")
              (cond
                ( (= (cdr (assoc 0 ex)) "VERTEX")
                  (setq ex (entget (cdr (assoc 330 ex))))
                  (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
                  (setq ex (entget (cdr (assoc -1 ex))))
                  (setq flag 1)
                )
                ( (= (cdr (assoc 0 ex)) "POLYLINE")
                  (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
                  (setq ex (entget (cdr (assoc -1 ex))))
                  (setq flag 1)
                )
              )
            )
            (if (= (cdr (assoc 0 ex)) "LWPOLYLINE")
              (if (> (abs (fix (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl)))))) 1.0)
                (progn
                  (setq c (inters (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl))) 0.05)) nil))
                  (setq arc1 (MR:3parc (vlax-curve-getstartpoint (cdr (assoc -1 ex))) (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) (mid (vlax-curve-getstartpoint (cdr (assoc -1 ex))) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (1- (vlax-curve-getendparam (cdr (assoc -1 ex)))))) c)) (list r r r)) c) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (1- (vlax-curve-getendparam (cdr (assoc -1 ex)))))))
                  (setq arc2 (MR:3parc (vlax-curve-getstartpoint (cdr (assoc -1 ex))) (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) c (mid (vlax-curve-getstartpoint (cdr (assoc -1 ex))) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (1- (vlax-curve-getendparam (cdr (assoc -1 ex)))))))) (list r r r)) c) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (1- (vlax-curve-getendparam (cdr (assoc -1 ex)))))))
                  (if (< (vla-get-arclength (vlax-ename->vla-object arc1)) (vla-get-arclength (vlax-ename->vla-object arc2)))
                    (entdel arc1)
                    (entdel arc2)
                  )
                  (entupd (cdr (assoc -1 (entmod (subst (cons 70 (* 128 (getvar 'plinegen))) (assoc 70 ex) ex)))))
                  (setq s (ssadd))
                  (cond
                    ( (not (vlax-erased-p arc1))
                      (ssadd arc1 s)
                    )
                    ( (not (vlax-erased-p arc2))
                      (ssadd arc2 s)
                    )
                  )
                  (ssadd (cdr (assoc -1 ex)) s)
                  ;|
                  (vl-cmdf "_.PEDIT" "_M" s "" "_J")
                  (while (< 0 (getvar 'cmdactive))
                    (vl-cmdf "")
                  )
                  |; ;;; for AutoCAD
                  (vl-cmdf "_.JOIN" s "") ;;; for BricsCAD
                )
                (progn
                  (setq par (- (max (fix (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl)))) (fix (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl))))) 0.5))
                  (setq p1 (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- par 0.5)) p2 (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ par 0.5)))
                  (setq c (inters (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (car pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getclosestpointto (cdr (assoc -1 ex)) (cadr pl))) 0.05)) nil))
                  (setq arc1 (MR:3parc p1 (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) (mid p1 p2) c)) (list r r r)) c) p2))
                  (setq arc2 (MR:3parc p1 (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) c (mid p1 p2))) (list r r r)) c) p2))
                  (if (< (vla-get-arclength (vlax-ename->vla-object arc1)) (vla-get-arclength (vlax-ename->vla-object arc2)))
                    (entdel arc1)
                    (entdel arc2)
                  )
                  (vl-cmdf "_.BREAK" (cdr (assoc -1 ex)) "" "_non" (trans p1 0 1) "_non" (trans p2 0 1))
                  (setq s (ssadd))
                  (cond
                    ( (not (vlax-erased-p arc1))
                      (ssadd arc1 s)
                    )
                    ( (not (vlax-erased-p arc2))
                      (ssadd arc2 s)
                    )
                  )
                  (ssadd (car (nentselp (osnap (cadr pl) "_nea"))) s)
                  (ssadd (car (nentselp (osnap (car pl) "_nea"))) s)
                  ;|
                  (vl-cmdf "_.PEDIT" "_M" s "" "_J")
                  (while (< 0 (getvar 'cmdactive))
                    (vl-cmdf "")
                  )
                  |; ;;; for AutoCAD
                  (vl-cmdf "_.JOIN" s "") ;;; for BricsCAD
                )
              )
            )
            (if flag
              (vl-cmdf "_.CONVERTPOLY" "_H" (cdr (assoc -1 ex)) "")
            )
          )
        )
      )
    )
    (if ss
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (setq ex (entget e))
        (if (wcmatch (cdr (assoc 0 ex)) "POLYLINE,VERTEX")
          (cond
            ( (= (cdr (assoc 0 ex)) "VERTEX")
              (setq ex (entget (cdr (assoc 330 ex))))
              (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
              (setq ex (entget (cdr (assoc -1 ex))))
              (setq flag 1)
            )
            ( (= (cdr (assoc 0 ex)) "POLYLINE")
              (vl-cmdf "_.CONVERTPOLY" "_L" (cdr (assoc -1 ex)) "")
              (setq ex (entget (cdr (assoc -1 ex))))
              (setq flag 1)
            )
          )
        )
        (if (= 1 (logand 1 (cdr (assoc 70 (setq ex (entget e))))))
          (progn
            (setq ptl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) ex)))
            (setq ptlpairs (mapcar (function (lambda ( a b ) (list a b))) ptl (append (cdr ptl) (list (car ptl)))))
            (setq pair (car (vl-sort ptlpairs (function (lambda ( a b ) (> (distance (car a) (cadr a)) (distance (car b) (cadr b))))))))
            (setq flagg 1)
            (vl-cmdf "_.BREAK" e "" "_non" (trans (polar (mid (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (car pair) (list (cdr (assoc 38 ex)))) e 0)))))) (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (cadr pair) (list (cdr (assoc 38 ex)))) e 0))))))) (angle (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (car pair) (list (cdr (assoc 38 ex)))) e 0)))))) (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (cadr pair) (list (cdr (assoc 38 ex)))) e 0))))))) 0.05) 0 1) "_non" (trans (polar (mid (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (car pair) (list (cdr (assoc 38 ex)))) e 0)))))) (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (cadr pair) (list (cdr (assoc 38 ex)))) e 0))))))) (angle (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (car pair) (list (cdr (assoc 38 ex)))) e 0)))))) (vlax-curve-getpointatparam e (float (fix (+ 0.1 (vlax-curve-getparamatpoint e (trans (append (cadr pair) (list (cdr (assoc 38 ex)))) e 0))))))) -0.05) 0 1))
          )
        )
        (vl-cmdf "_.CHAMFER" "_P" e)
        (while (< 0 (getvar 'cmdactive))
          (vl-cmdf "")
        )
        (setq ex (entget e))
        (repeat (fix (/ (+ 0.1 (setq n (1- (vlax-curve-getendparam (cdr (assoc -1 ex)))))) 2.0))
          (setq par (+ (setq n (- n 2.0)) 1.5))
          (setq p1 (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (rem (- par 0.5) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))) p2 (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (rem (+ par 0.5) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))))
          (setq c (inters (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1- par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1- par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (- (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1+ par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))))) 0.05)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (+ (vlax-curve-getparamatpoint (cdr (assoc -1 ex)) (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1+ par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))))) 0.05)) nil))
          (setq arc1 (MR:3parc p1 (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) (mid p1 p2) c)) (list r r r)) c) p2))
          (setq arc2 (MR:3parc p1 (mapcar (function +) (mapcar (function *) (unit (mapcar (function -) c (mid p1 p2))) (list r r r)) c) p2))
          (if (< (vla-get-arclength (vlax-ename->vla-object arc1)) (vla-get-arclength (vlax-ename->vla-object arc2)))
            (entdel arc1)
            (entdel arc2)
          )
          (setq p3 (trans (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1- par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex)))))))) 0 1) p4 (trans (vlax-curve-getpointatparam (cdr (assoc -1 ex)) (float (rem (1+ par) (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex)))))))) 0 1))
          (vl-cmdf "_.BREAK" (cdr (assoc -1 ex)) "" "_non" (trans p1 0 1) "_non" (trans p2 0 1))
          (setq s (ssadd))
          (cond
            ( (not (vlax-erased-p arc1))
              (ssadd arc1 s)
            )
            ( (not (vlax-erased-p arc2))
              (ssadd arc2 s)
            )
          )
          (ssadd (car (nentselp p3)) s)
          (ssadd (car (nentselp p4)) s)
          ;|
          (vl-cmdf "_.PEDIT" "_M" s "" "_J")
          (while (< 0 (getvar 'cmdactive))
            (vl-cmdf "")
          )
          |; ;;; for AutoCAD
          (vl-cmdf "_.JOIN" s "") ;;; for BricsCAD
        )
        (if flagg
          (progn
            ;|
            (if (not (eq (cdr (assoc -1 ex)) (entlast)))
              (setq ex (entget (entlast)))
            )
            (setq n (fix (+ 0.1 (vlax-curve-getendparam (cdr (assoc -1 ex))))))
            (setq ex (mapcar (function (lambda ( x ) (if (= (car x) 10) (progn (setq k (if (not k) 0 (1+ k))) (if (or (= k 0) (= k n)) 1 x)) x))) ex))
            (setq k nil)
            (setq ex (append (reverse (cdr (member 1 (cdr (member 1 (reverse ex)))))) (member (assoc 10 (cdr (member 1 ex))) (reverse (cdr (member 1 (reverse ex))))) (cdr (member 1 (cdr (member 1 ex))))))
            (setq ex (subst (cons 90 (1- n)) (assoc 90 ex) ex))
            (setq ex (subst (cons 70 (1+ (* 128 (getvar 'plinegen)))) (assoc 70 ex) ex))
            (entupd (cdr (assoc -1 (entmod ex))))
            |; ; something's wrong with this version - try to debug if you want ;

            (vl-cmdf "_.TRIM" "_L" "" "_non" (trans (vlax-curve-getstartpoint (entlast)) 0 1) "_non" (trans (vlax-curve-getendpoint (entlast)) 0 1) "")
            (vla-put-closed (vlax-ename->vla-object (entlast)) :vlax-true)
  
          )
        )
        (if flag
          (vl-cmdf "_.CONVERTPOLY" "_H" (cdr (assoc -1 ex)) "")
        )
        (setq flag nil flagg nil)
      )
    )
  )
  (*error* nil)
)

 

Edited by marko_ribar
  • Like 3
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...