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

0 Members and 1 Guest are viewing this topic.

PM

  • Bull Frog
  • Posts: 277
Help with DoubleOffset lisp - LeeMac Code
« on: April 10, 2021, 10:42:26 AM »
Hi. I am using LeeMac code for Double offset . I want an update to this code.
I need to select all lines in layer "ROOF-AXIS" and double offset them (0.08m of each side) and the put the offset lines in layer "ROOF"


Code - Auto/Visual Lisp: [Select]
  1.   (command "_layer" "_m" "ROOF" "_c" "90" "" "")
  2.  

Code - Auto/Visual Lisp: [Select]
  1. (defun c:DOff2 nil (c:DoubleOffset))
  2.  
  3. (defun c:DoubleOffset ( / *error* _StartUndo _EndUndo DoubleOffset doc exitflag layer mpoint obj object of point sel symbol value )
  4.  
  5.   (defun *error* ( msg )    
  6.     (and doc (_EndUndo doc))
  7.     (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
  8.         (princ (strcat "\n** Error: " msg " **")))
  9.     (princ)
  10.   )
  11.  
  12.   (defun _StartUndo ( doc ) (vla-StartUndoMark doc))
  13.  
  14.   (defun _EndUndo   ( doc ) (if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-EndUndomark doc)))
  15.  
  16.   (defun DoubleOffset ( object offset layer )
  17.     (mapcar
  18.       (function
  19.         (lambda ( o )
  20.           (if
  21.             (and
  22.               (not
  23.                 (vl-catch-all-error-p
  24.                   (setq o
  25.                     (vl-catch-all-apply
  26.                       (function vlax-invoke) (list object 'Offset o)
  27.                     )
  28.                   )
  29.                 )
  30.               )
  31.               layer
  32.             )
  33.             (mapcar
  34.               (function
  35.                 (lambda ( o )
  36.                   (vla-put-layer o (getvar 'CLAYER))
  37.                 )
  38.               )
  39.               o
  40.             )
  41.           )
  42.         )
  43.       )
  44.       (list offset (- offset))
  45.     )
  46.   )
  47.  
  48.  
  49.   (mapcar
  50.     '(lambda ( symbol value ) (or (boundp symbol) (set symbol value)))
  51.     '(*dOff:Erase *dOff:Layer) '("No" "Source")
  52.   )
  53.  
  54.   (if
  55.     (progn
  56.       (while
  57.         (progn
  58.           (princ
  59.             (strcat
  60.               "\nCurrent Settings: Erase source="
  61.               *dOff:Erase
  62.               "  Layer="
  63.               *dOff:Layer
  64.               "  OFFSETGAPTYPE="
  65.               (itoa (getvar 'OFFSETGAPTYPE))
  66.             )
  67.           )
  68.           (initget 6 "Through Erase Layer")
  69.           (setq of
  70.             (getdist
  71.               (strcat "\nSpecify Offset Distance [Through/Erase/Layer] <"
  72.                 (if (minusp (getvar 'OFFSETDIST)) "Through"  (rtos (getvar 'OFFSETDIST))) "> : "
  73.               )
  74.             )
  75.           )
  76.           (cond
  77.             (
  78.               (null of) (not (setq of (getvar 'OFFSETDIST)))
  79.             )
  80.             (
  81.               (eq "Through" of) (setq of (setvar 'OFFSETDIST -1)) nil
  82.             )
  83.             (
  84.               (eq "Erase" of) (initget "Yes No")
  85.  
  86.               (setq *dOff:Erase
  87.                 (cond
  88.                   (
  89.                     (getkword
  90.                       (strcat "\nErase source object after offsetting? [Yes/No] <" *doff:Erase "> : ")
  91.                     )
  92.                   )
  93.                   ( *dOff:Erase )
  94.                 )
  95.               )
  96.             )
  97.             (
  98.               (eq "Layer" of) (initget "Current Source")
  99.  
  100.               (setq *dOff:Layer
  101.                 (cond
  102.                   (
  103.                     (getkword
  104.                       (strcat "\nEnter layer option for offset objects [Current/Source] <" *dOff:Layer "> : ")
  105.                     )
  106.                   )
  107.                   ( *dOff:Layer )
  108.                 )
  109.               )
  110.             )
  111.             ( of (setvar 'OFFSETDIST of) nil )
  112.           )
  113.         )
  114.       )
  115.       of
  116.     )
  117.     (while
  118.       (progn
  119.         (or ExitFlag
  120.           (progn (initget "Exit")
  121.             (setq sel (entsel "\nSelect object to offset or [Exit] <Exit> : "))
  122.           )
  123.         )
  124.        
  125.         (cond
  126.           (
  127.             (or ExitFlag (null sel) (eq sel "Exit")) nil
  128.           )
  129.           ( (vl-consp sel)
  130.  
  131.             (_EndUndo doc) (_StartUndo doc)
  132.  
  133.             (if (and (wcmatch (cdr (assoc 0 (entget (car sel)))) "ARC,CIRCLE,ELLIPSE,SPLINE,LWPOLYLINE,XLINE,LINE")
  134.                      (setq obj (vlax-ename->vla-object (car sel))))
  135.  
  136.               (if (minusp of)
  137.                 (if
  138.                   (progn (initget "Exit Multiple")
  139.                     (and
  140.                       (setq point (getpoint "\nSpecify through point or [Exit/Multiple] <Exit> : "))
  141.                       (not (eq "Exit" point))
  142.                     )
  143.                   )
  144.                   (if (eq "Multiple" point)
  145.                     (while
  146.                       (progn (initget "Exit")
  147.                         (setq mpoint (getpoint "\nSpecify through point or [Exit] <next object> : "))
  148.  
  149.                         (cond
  150.                           (
  151.                             (eq "Exit" mpoint)
  152.  
  153.                             (if (eq "Yes" *dOff:Erase) (vla-delete obj))
  154.  
  155.                             (not (setq ExitFlag t))
  156.                           )
  157.                           (
  158.                             (null mpoint)
  159.  
  160.                             (if (eq "Yes" *dOff:Erase) (vla-delete obj))
  161.  
  162.                             nil
  163.                           )
  164.                           (
  165.                             (listp mpoint)
  166.                            
  167.                             (DoubleOffset obj
  168.                               (distance (trans mpoint 1 0)
  169.                                 (vlax-curve-getClosestPointto (car sel) (trans mpoint 1 0) t)
  170.                               )
  171.                               (eq "Current" *dOff:Layer)
  172.                             )
  173.                            t
  174.                           )
  175.                         )
  176.                       )
  177.                     )
  178.                     (progn
  179.                       (DoubleOffset obj
  180.                         (distance (trans point 1 0)
  181.                           (vlax-curve-getClosestPointto (car sel) (trans point 1 0) t)
  182.                         )
  183.                         (eq "Current" *dOff:Layer)
  184.                       )
  185.                       (if (eq "Yes" *dOff:Erase) (vla-delete obj))
  186.                      t
  187.                     )
  188.                   )
  189.                   (setq ExitFlag t)
  190.                 )
  191.                 (progn
  192.                   (DoubleOffset obj of (eq "Current" *dOff:Layer))
  193.  
  194.                   (if (eq "Yes" *dOff:Erase) (vla-delete obj))
  195.                 )
  196.               )
  197.               (princ "\n** Cannot Offset that Object **")
  198.             )
  199.            t
  200.           )
  201.         )
  202.       )
  203.     )
  204.   )  
  205.   (_EndUndo doc) (princ)
  206. )  
  207.  
  208.  (princ)
  209.  
  210.  

Thanks

Tharwat

  • Swamp Rat
  • Posts: 613
  • Hypersensitive
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #1 on: April 10, 2021, 12:09:20 PM »
Here you go.
Code - Auto/Visual Lisp: [Select]
  1. (defun c:Test ( / sel int ent )
  2.   ;; Tharwat - Date : 10.Apr.2021       ;;
  3.   (and (or (tblsearch "LAYER" "ROOF")
  4.          (alert "Layer name < ROOF >  was not found in this drawing to continue!")
  5.          )
  6.      (princ "\nSelect lines on layer < ROOF-AXIS > to offset on two sides 0.08 m : ")
  7.      (setq int -1 sel (ssget "_:L" '((0 . "LINE")(8 . "ROOF-AXIS"))))
  8.      (while (setq int (1+ int) ent (ssname sel int))
  9.        (foreach off '(0.08 -0.08)
  10.          (vla-put-layer (car (vlax-invoke (vlax-ename->vla-object ent) 'offset off)) "ROOF")
  11.          )
  12.        )
  13.      )
  14.  

PM

  • Bull Frog
  • Posts: 277
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #2 on: April 10, 2021, 12:28:56 PM »
HI Tharwat

I try to change your code to automatic select this lines by is not work !!!



Code - Auto/Visual Lisp: [Select]
  1.     (defun c:Test ( / sel int ent )
  2.       ;; Tharwat - Date : 10.Apr.2021       ;;
  3.       (and (or (tblsearch "LAYER" "ROOF")
  4.              (alert "Layer name < ROOF >  was not found in this drawing to continue!")
  5.              )
  6.          ;(princ "\nSelect lines on layer < ROOF-AXIS > to offset on two sides 0.08 m : ")
  7.          (ssget "_x" '((0 . "*LINE") (8 . "ROOF-AXIS")))  ; < ----- add this line
  8.          (setq int -1 sel (ssget "_:L" '((0 . "LINE")(8 . "ROOF-AXIS"))))
  9.          (while (setq int (1+ int) ent (ssname sel int))
  10.            (foreach off '(0.08 -0.08)
  11.              (vla-put-layer (car (vlax-invoke (vlax-ename->vla-object ent) 'offset off)) "ROOF")
  12.              )
  13.            )
  14.          )
  15.     (princ)
  16.     ) (vl-load-com)
  17.      
  18.  
  19.  

Tharwat

  • Swamp Rat
  • Posts: 613
  • Hypersensitive
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #3 on: April 10, 2021, 12:32:57 PM »
Replace this part from my original posted codes and please modify your post and remove your posted codes.
Code - Auto/Visual Lisp: [Select]
  1.  (setq int -1 sel (ssget "_X" '((0 . "LINE")(8 . "ROOF-AXIS"))))

Be sure to have the layer ROOF-AXIS unlocked.


PM

  • Bull Frog
  • Posts: 277
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #4 on: April 10, 2021, 12:34:51 PM »
Thanks

PM

  • Bull Frog
  • Posts: 277
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #5 on: April 10, 2021, 12:42:25 PM »
I want ro ask you some thing else . Is it possible after the offset to fillet 0 all this lines in ROOF layer?

BIGAL

  • Swamp Rat
  • Posts: 831
  • 30 + years of using Autocad
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #6 on: April 10, 2021, 09:13:33 PM »
It would be better to make all the joining lines to plines use pedit Join, then run the offset lisp it will auto fillet then.
A man who never made a mistake never made anything

PM

  • Bull Frog
  • Posts: 277
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #7 on: April 11, 2021, 02:26:45 AM »
Hi Bigal. I use this code to make roof. I did a combination with Tharwat code. My results is in the attach file. I want to trim -extend the offset lines to perimetric roof polylime  and fill with ANSI31 hatch like the attach file.
« Last Edit: April 11, 2021, 02:32:47 AM by PM »

PM

  • Bull Frog
  • Posts: 277
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #8 on: April 11, 2021, 02:34:02 AM »
The ROOF dwg  updated in the previous post

BIGAL

  • Swamp Rat
  • Posts: 831
  • 30 + years of using Autocad
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #9 on: April 11, 2021, 08:43:22 PM »
I think the ridge tops can be filleted by using a circle approach, and checking for a intersectwith, not sure can be automated, may look at making a circle on each end of red lines. The same with eave end it will be a trim or extend. Will have a think about it.

polygon
get co-ord
(setq ss (ssget "F" co-ord '((8 . "ROOF")(0 . "LINE"))))
need to do a distanceatpoint along the polygon via  intersectwith so can sort the line order into pairs then can fillet
« Last Edit: April 11, 2021, 09:01:14 PM by BIGAL »
A man who never made a mistake never made anything

PM

  • Bull Frog
  • Posts: 277
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #10 on: April 12, 2021, 11:12:19 AM »
can any one fix it?

BIGAL

  • Swamp Rat
  • Posts: 831
  • 30 + years of using Autocad
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #11 on: April 12, 2021, 11:22:04 PM »
Need some time made a start on it be patient.
A man who never made a mistake never made anything

PM

  • Bull Frog
  • Posts: 277
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #12 on: April 13, 2021, 01:37:20 AM »
Thanks BIGAL

BIGAL

  • Swamp Rat
  • Posts: 831
  • 30 + years of using Autocad
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #13 on: April 15, 2021, 12:30:16 AM »
Sorry took so long had a few other tasks, it only does ridge caps at moment, there is one spot where in you sample it will not work as you have 2 ridges to close so the search polygon gets confused. So just pick the top of the red line. The same method should be able to be used on the eaves.

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)
(while (setq pt (getpoint "\nPick ridge point "))
(setvar 'osmode 0)
;(setq pt2 (getpoint pt "\nPick gap in ridge lines "))
; (setq ang  (angle pt pt2))
(setq ang 0.0)
(setq pi20 (/ (* 2.0 pi) 20.0))
(setq co-ord '())
(repeat 20
(setq pt2 (polar pt (setq ang (+ pi20 ang)) 0.3))
(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 "fillet" pt1 pt2  )
(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" pt1 pt2  )

(setvar 'osmode 1)

)
(setvar 'osmode oldsnap)
(princ)

)
(c:test)


A man who never made a mistake never made anything

PM

  • Bull Frog
  • Posts: 277
Re: Help with DoubleOffset lisp - LeeMac Code
« Reply #14 on: April 15, 2021, 01:49:40 AM »
Hi BIGAL . Thanks for your time. I try your code but is not working as i expect. Is faster to do filet 0 . Your code create arcs in the roof and became a mess.

Thanks again

BIGAL

  • Swamp Rat
  • Posts: 831
  • 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: 831
  • 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.