Author Topic: Help with DoubleOffset lisp - LeeMac Code  (Read 1237 times)

0 Members and 1 Guest are viewing this topic.

BIGAL

  • Swamp Rat
  • Posts: 830
  • 30 + years of using Autocad
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #15 on: April 15, 2021, 07:38:56 PM »
I tested on your dwg and it worked ok will look further into it. Would not have posted if not working.

I did all my testing in Bricscad and it works perfect falls over in Autocad so understand not working, not sure why its happening. Will make it work.

« Last Edit: April 15, 2021, 07:44:21 PM by BIGAL »
A man who never made a mistake never made anything

BIGAL

  • Swamp Rat
  • Posts: 830
  • 30 + years of using Autocad
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #16 on: April 15, 2021, 11:58:25 PM »
The code works in Bricscad but not in Autocad. Which was disappointing I am now rewriting for both.

 I have found that Autocad must be able to see the points when filleting and that may be the problem. So will look at zooming or an alternative of picking the fillet points.

There is a problem in one area it will not work as you have two ridges to close to work out the line order.

Re outside eave can use extrim to auto trim overshoot, just did manual very easy, extended everything then extrim.

I have had to revert back to a version 1 to get to work in Autocad. You need to drag a start angle line. Its not perfect. I will work on it. Doing some weird things when getting the line order.

The fillet problem is to do with the pick point needs to be closer to the fillet point, say 20% instead of mid pt. Bricscad works even if unseen.

Code: [Select]
; fillet offset roof ridges for offset lines equal ridge capping.
; by AlanH April 2021 info@alanh.com.au

(defun AHpllst ( lstpl / x)
(command "_pline")
(while (= (getvar "cmdactive") 1 )
(repeat (setq x (length lstpl))
(command (nth (setq x (- x 1)) lstpl))
)
(command "")
)
)


(defun c:test  ( / oldsnap)
(setq oldsnap (getvar 'osmode))
(setvar 'osmode 1)
(setq pi30 (/ (* 2.0 pi) 30.0))

(while (setq pt (getpoint "\nPick ridge point Enter to exit "))

(setq pt2 (getpoint pt "\nPick internal gap in ridge lines "))
(setq ang  (angle pt pt2))
(setvar 'osmode 0)

(setq co-ord '())
(repeat 30
(setq pt2 (polar pt (setq ang (+ pi30 ang)) 0.21))
(setq co-ord (cons pt2 co-ord))
)
;(setq co-ord (cons (last  co-ord) co-ord))
(AHpllst co-ord)

(setq obj1 (vlax-ename->vla-object (entlast)))

(setq ss (ssget "F" co-ord '((0 . "LINE")(8 . "ROOF"))))

(setq lst '())
(repeat (setq x (sslength ss))
(setq ent (ssname ss (setq x (- x 1))))
(setq obj2 (vlax-ename->vla-object ent))
(setq pt (vlax-invoke obj2 'intersectWith obj1 acExtendnone))
(setq dist (vlax-curve-getdistatpoint obj1 pt))
(setq lst (cons (list dist pt (cdr (assoc -1 (entget ent)))) lst))
)
(setq lst (vl-sort lst '(lambda (x y) (< (car x)(car y)))))

(vla-delete obj1)
(setvar 'filletrad 0.0)

(setq x 1)
(setvar 'osmode 512)
(setq x 1)
(repeat (- (/ (length lst) 2) 1)
(setq l1 (entget (nth 2 (nth x lst))))
( setq pt1 (mapcar '* (mapcar '+ (cdr (assoc 10 l1)) (cdr (assoc 11 l1))) '(0.5 0.5)))
(setq l2 (entget (nth 2 (nth (+ x 1) lst))))
( setq pt2 (mapcar '* (mapcar '+ (cdr (assoc 10 l2)) (cdr (assoc 11 l2))) '(0.5 0.5)))
(command "zoom" "C" pt 5.0)
;(command "fillet" pt1 pt2  )
(command "fillet" (nth 2 (nth x lst)) pt2  )
(command "zoom" "P" )
(setq x (+ x 2))
)
(setq l1 (entget (nth 2 (nth 0 lst))))
( setq pt1 (mapcar '* (mapcar '+ (cdr (assoc 10 l1)) (cdr (assoc 11 l1))) '(0.5 0.5)))
(setq l2 (entget (nth 2 (last lst))))
( setq pt2 (mapcar '* (mapcar '+ (cdr (assoc 10 l2)) (cdr (assoc 11 l2))) '(0.5 0.5)))
(command "fillet" (nth 2 (nth 0 lst)) pt2  )

(setvar 'osmode 1)

)
(setvar 'osmode oldsnap)
(princ)

)
(c:test)



For eave tested in Autocad.

Code: [Select]
; Clean up eave line for ridge capping
; By AlanH April 2021

(defun c:test2 ( / oldsnap ent obj pmin pmax mp outpt off1 obj1 obj2 ss co-ord lst intpt )
(setq oldsnap (getvar 'osmode))
(setq ent (car (entsel "\nPick eave pline ")))

(setq obj (vlax-ename->vla-object ent))
(vla-GetBoundingBox obj 'minpoint 'maxpoint)
(setq pmin (vlax-safearray->list minpoint))
(setq pmax (vlax-safearray->list maxpoint))
(setq mp (mapcar '* (mapcar '+ pmin pmax) '(0.5 0.5)))
(setq outpt (polar pmax (angle pmin pmax) 1.0))

(command "offset" 0.25 ent mp "")
(setq off1 (entlast))
(setq obj1 (vlax-ename->vla-object off1))
(setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget off1))))

(setq ss (ssget "F" co-ord '((0 . "line"))))

(setq lst '())
(repeat (setq x (sslength ss))
(setq obj2  (vlax-ename->vla-object (ssname ss (setq x (- x 1)))))
(setq intpt (vlax-invoke obj2 'intersectWith obj1 acExtendNone))
(setq lst (cons intpt lst))
)
(setq lst (cons (last lst) lst))

(command "erase" off1 "")

(command "offset" 0.25 ent outpt "")
(setq off1 (entlast))

(setvar 'osmode 512)

(command "extend" off1 "" "F")
(while (= (getvar "cmdactive") 1 )
(repeat (setq x (length lst))
(command (nth (setq x (- x 1)) lst))
)
(command "" "")
)

(command "erase" off1 "")
(if (null etrim) (load "extrim.lsp"))
(etrim ent outpt)

(setvar 'osmode oldsnap)
(princ)

) ; defun
(c:test2)

Problem spot if I decrease radius then does not work else where.


A man who never made a mistake never made anything

PM

  • Bull Frog
  • Posts: 277
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #17 on: April 16, 2021, 02:26:54 AM »
Hi BIGAL, I find this code . I dont't know if is possoble to select all lines in roof layer and fillet them.   (i find it here https://forums.augi.com/showthread.php?44929-Looking-for-a-routine-for-Multiple-Fillet/page3&s=8db7f7c3ef67f5bb37fca77a4f69a5a7)

Code - Auto/Visual Lisp: [Select]
  1. (defun c:mcha ( / *error* mid AssocOn ss i ent p1 p2 lin linn lins flins ptlst1 pt1 pt11 ptlst2 pt2 pt22 chpts chamfers )
  2.  
  3.   (defun *error* ( msg )
  4.     (if chma (setvar 'chamfera chma))
  5.     (if chmb (setvar 'chamferb chmb))
  6.     (if chmm (setvar 'chammode chmm))
  7.   )
  8.  
  9.   (defun mid ( p1 p2 )
  10.     (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
  11.   )
  12.  
  13.   (defun AssocOn ( SearchTerm Lst func fuzz )
  14.     (car
  15.       (vl-member-if
  16.         (function
  17.           (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
  18.         )
  19.         lst
  20.       )
  21.     )
  22.   )
  23.  
  24.   (mapcar 'set '(chma chmb chmm) (mapcar 'getvar '(chamfera chamferb chammode)))
  25.   (mapcar 'setvar '(chamfera chamferb chammode) '(0 0 0))
  26.   (prompt "\nSelect line entities")
  27.   (while (not (setq ss (ssget "_:L" '((0 . "LINE"))))))
  28.   (setq i -1)
  29.   (while (setq ent (ssname ss (setq i (1+ i))))
  30.     (setq p1 (trans (vlax-curve-getstartpoint ent) 0 1))
  31.     (setq p2 (trans (vlax-curve-getendpoint ent) 0 1))
  32.     (setq lin (list p1 p2))
  33.     (setq lins (cons lin lins))
  34.   )
  35.   (setq flins (apply 'append lins))
  36.   (foreach lin lins
  37.     (setq ptlst1 (vl-sort flins '(lambda ( a b ) (< (distance (car lin) a) (distance (car lin) b)))))
  38.     (if (equal (cadr ptlst1) (cadr lin) 1e-8) (setq pt1 (caddr ptlst1)) (setq pt1 (cadr ptlst1)))
  39.     (if (setq linn (assocon pt1 lins 'car 1e-8)) (setq pt11 (mid (car linn) (cadr linn))))
  40.     (if (setq linn (assocon pt1 lins 'cadr 1e-8)) (setq pt11 (mid (car linn) (cadr linn))))
  41.     (setq ptlst2 (vl-sort flins '(lambda ( a b ) (< (distance (cadr lin) a) (distance (cadr lin) b)))))
  42.     (if (equal (cadr ptlst2) (car lin) 1e-8) (setq pt2 (caddr ptlst2)) (setq pt2 (cadr ptlst2)))
  43.     (if (setq linn (assocon pt2 lins 'car 1e-8)) (setq pt22 (mid (car linn) (cadr linn))))
  44.     (if (setq linn (assocon pt2 lins 'cadr 1e-8)) (setq pt22 (mid (car linn) (cadr linn))))
  45.     (setq chpts (list pt11 (mid (car lin) (cadr lin))) chamfers (cons chpts chamfers) chpts (list pt22 (mid (car lin) (cadr lin))) chamfers (cons chpts chamfers))
  46.   )
  47.   (foreach chpts chamfers
  48.     (command "_.chamfer" (car chpts) (cadr chpts))
  49.   )
  50.   (*error* nil)
  51.   (princ)
  52. )
  53.  

\Thanks

PM

  • Bull Frog
  • Posts: 277
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #18 on: April 16, 2021, 11:11:00 AM »
Hi BIGAL .I find a lisp code that creates multy boundaries. Is any way to use this code and bypass fillet.

Code - Auto/Visual Lisp: [Select]
  1. ;Create closed polylines from selected objects
  2. ;Stefan M. v1.01 07.03.2014
  3. ;updated - v1.02 16.10.2018
  4. ;updated - v1.03 27.11.2018
  5. (defun c:epl ( / *error* break_object l2p ms ss i z_dir o_dir e lst segments pa dr aa ce reg ea)
  6.   (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
  7.   (setq pa (getvar 'peditaccept)
  8.         dr (getvar 'draworderctl)
  9.         ce (getvar 'cmdecho)
  10.         aa 0.00
  11.   )
  12.  
  13.   (defun *error* (msg)
  14.     (and
  15.       msg
  16.       (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
  17.       (princ (strcat "\nError: " msg))
  18.       )
  19.     (foreach x (append segments lst) (vl-catch-all-apply 'vla-delete (list x)))
  20.     (setvar 'peditaccept pa)
  21.     (setvar 'draworderctl dr)
  22.     (setvar 'cmdecho ce)
  23.     (vla-endundomark acDoc)
  24.     (princ)
  25.   )
  26.  
  27.   (defun l2p (l) (if l (cons (list (car l) (cadr l) (caddr l)) (l2p (cdddr l)))))
  28.  
  29.   (defun break_object (e points / object_type start center end radius normal arc res)
  30.     (if points
  31.       (progn
  32.         (setq points
  33.           (vl-sort points
  34.             (function
  35.               (lambda (a b)
  36.                 (<
  37.                   (vlax-curve-getdistatpoint e (vlax-curve-getclosestpointto e a))
  38.                   (vlax-curve-getdistatpoint e (vlax-curve-getclosestpointto e b))
  39.                 )
  40.               )
  41.             )
  42.           )
  43.         )
  44.         (cond
  45.           ((eq (setq object_type (vla-get-ObjectName e)) "AcDbLine")
  46.            (setq start (vlax-curve-getstartpoint e))
  47.            (while points
  48.              (if (> (distance start (car points)) 1e-5)
  49.                (setq res (cons (vlax-invoke ms 'addline start (setq start (car points))) res))
  50.                )
  51.              (setq points (cdr points))
  52.              )
  53.            )
  54.           (T
  55.            (if
  56.              (eq object_type "AcDbArc")
  57.              (setq start  (vlax-curve-getStartParam e))
  58.              (setq start  (vlax-curve-getparamatpoint e (car points))
  59.                    points (reverse (cons (car points) (reverse (cdr points))))
  60.              )
  61.            )
  62.            (setq   center (vla-get-Center e)
  63.                    radius (vla-get-Radius e)
  64.                    normal (vla-get-Normal e)
  65.            )
  66.            (while points
  67.              (if (not (equal start (setq end (vlax-curve-getparamatpoint e (car points))) 1e-5))
  68.                (progn
  69.                  (setq arc (vla-AddArc ms center radius start end))
  70.                  (vla-put-Normal arc normal)
  71.                  (setq res (cons arc res))
  72.                )
  73.              )
  74.              (setq points (cdr points)
  75.                    start end)
  76.              )
  77.            )
  78.          )
  79.        )
  80.      )
  81.     res
  82.   )
  83.          
  84.   (if
  85.     (setq ss (ssget ":L" '((0 . "LINE,LWPOLYLINE,ARC,CIRCLE"))))
  86.     (progn
  87.       (setq z_dir (trans '(0 0  1) 1 0 t))
  88.       (repeat (setq i (sslength ss))
  89.         (setq i (1- i)
  90.               e (ssname ss i)
  91.               o_dir (cdr (assoc 210 (entget e)))
  92.               e (vlax-ename->vla-object e)
  93.         )
  94.         (if
  95.           (equal o_dir z_dir 1e-8)
  96.           (if
  97.             (eq (vla-get-ObjectName e) "AcDbPolyline")
  98.             (foreach x (vlax-invoke e 'Explode)
  99.               (setq lst (cons x lst))
  100.             )
  101.             (setq lst (cons (vla-copy e) lst))
  102.           )
  103.         )
  104.       )
  105.       (if
  106.         (and
  107.           (setq segments
  108.             (apply 'append
  109.               (mapcar
  110.                 (function
  111.                   (lambda (e / l)
  112.                     (break_object e
  113.                       (progn
  114.                         (foreach other (vl-remove e lst)
  115.                           (foreach x (l2p (vlax-invoke e 'intersectwith other acExtendNone))
  116.                              (if
  117.                                (equal x (vlax-curve-getclosestpointto e x) 1e-8)
  118.                                (setq l (cons x l))
  119.                              )
  120.                           )
  121.                         )
  122.                         (if
  123.                           (eq (vla-get-ObjectName e) "AcDbCircle")
  124.                           l
  125.                           (cons (vlax-curve-getendpoint e) l)
  126.                         )
  127.                       )
  128.                     )
  129.                   )
  130.                 )
  131.                 lst
  132.               )
  133.             )
  134.           )
  135.           (not
  136.             (vl-catch-all-error-p
  137.               (setq reg
  138.                (vl-catch-all-apply 'vlax-invoke (list ms 'AddRegion segments))
  139.               )
  140.             )
  141.           )
  142.         )
  143.         (progn
  144.           (setvar 'peditaccept 1)
  145.           (setvar 'draworderctl 0)
  146.           (setvar 'cmdecho 0)
  147.           (foreach x reg
  148.             (setq x (vlax-vla-object->ename x))
  149.             (command "_explode" x)
  150.             (command "_pedit" "_m" "_p" "" "_j" "" "")
  151.             (if (> (vlax-curve-getArea (entlast)) aa) (setq aa (vlax-curve-getArea (setq ea (entlast)))))
  152.           )
  153.           (entdel ea)
  154.           (setvar 'peditaccept pa)
  155.           (setvar 'draworderctl dr)
  156.           (setvar 'cmdecho ce)
  157.         )
  158.         (princ "\nValid region(s) not found")
  159.       )
  160.     )
  161.   )
  162.   (*error* nil)
  163.   (princ)
  164. )
  165.  
  166.  
  167.