Offset delete fixed with associated hatches (Minor problem - Hatch won't update)

[3dwannab]

Hi all,

 

I have this program below. It offsets and deletes the original objects but unlike the built in command for polylines that have a hatch associated to them the built in command doesn't take the hatch with it.

 

This program fixes this, however I can't seem to get the hatch to update until I exit the command fully. I want it so that after every offset it goes straight back into the command but as you can see the hatch doesn't update mid run of the program.

 

PS: Credit to the authors of the functions used. Mentioned in the code below.

 

 

Code:

(vl-load-com)

;|

ABOUT
- Offsets by specified distance and deletes the original but in the case of
  Polylines it recreates them. This is to preserve the associative hatches if
  there any.
- Distance remembered through different ACAD sessions. Variable saved to the
  registry.
- Non Polyline code done by user ronjonp here:
  http://www.cadtutor.net/forum/showthread.php?24646-Offset-and-delete-source&p=699122&viewfull=1#post699122
- Polyline recreation code from here:
  https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-polyine-geometry-with-another-polylines-geometry-lisp/m-p/7134030#M354113

MY EDITS, BY 3dwannab
2018.03.24
- I've added a loop to pick more objects for offset after the first one is
  completed. and error checking to only select offset-able objects.
- It also doesn't fail if nothings selected.

2022.06.25
- Added support to recreate Polyline as the offset position. This will preserve
  any associative hatches if there any.
- Added proper undo handling.

USAGE
'ODEL' or 'OFFSET_DELETE'.

TO DO
- Tey get the hatches to update after every offset.

|;

(defun c:ODEL nil (c:OFFSET_DELETE))

(defun c:OFFSET_DELETE ( / acDoc *error* cordins entOrg entPlTemp offDisStr ptOffside typ )

  (defun *error* (errmsg)
    (and acDoc (vla-EndUndoMark acDoc))
    (and errmsg
      (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*"))
      (princ (strcat "\n<< Error: " errmsg " >>\n"))
      )
    )

  (vla-StartUndoMark (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object))))

  (setq offDisStr (atof (cond ((getenv "MyOffsetProgram")) ("1")))) ;; Get saved offset from registry or default to 1

  (while (if (and ;; Prompt for distance, if nil use default

    (setq offDisStr (cond ((getdist (strcat "\nOffset distance <" (vl-princ-to-string offDisStr) ">: "))) (offDisStr)))

    (progn
      (while
        (not
          (and
            (setq entOrg (fentsel (strcat"\nSelect object to offset :\n") "*"))
            (= (vlax-method-applicable-p (vlax-ename->vla-object (car entOrg)) "Offset") T) ;; Will only select objects that can be offset
            )
          )
        (prompt "\nNothing offset-able selected!")
        )
      (setq ptOffside (cond ((getpoint "\nSpecify point on side to offset : ")) ((cadr entOrg)))) ;; Pick a side to offset or use point in entsel
      ) ;; End progn

    )

  ;; Offset objects
  (progn

    (setq typ (cdr (assoc 0 (entget (car entOrg))))) ;; Get the type of object, i.e. POLYLINE, LINE etc

    ;; Offset all other items apart from polylines
    (cond
      ((not (wcmatch typ "*POLYLINE"))
        (princ "\nThis is not a POLYLINE\n")
        (while (command "_.offset" offDisStr (car entOrg) ptOffside ""))
        (entdel (car entOrg)) ;; Delete original (entdel won't **** the bed if the object is locked)
        )
      ) ;; End cond for all but POLYLINES

    ;; Offset polylines only but recreate them based on the offset polyline verts
    (cond
      ((wcmatch typ "*POLYLINE")
        (princ "\nThis is a PL\n")
        (while (command "_.offset" offDisStr (car entOrg) ptOffside ""))
        (setq cordins (@Plist (entlast))) ;; Get the coordinates of the offset polyline
        (setq entPlTemp (entlast)) ;; Set the variable for the newly created temporary entity
        ;; Put the properties of the new offset polyline to the original one to preserve
        ;; any associative hatches there may or not be.
        (if entPlTemp
          (progn
            (@put_data (vlax-ename->vla-object (car entOrg)) (@Plist entPlTemp))
            (entdel entPlTemp) ;; Delete the temporary polyline
            )
          ) ;; End if entPlTemp
        )
      ) ;; End cond for POLYLINES

    (setenv "MyOffsetProgram" (vl-princ-to-string offDisStr)) ;; Write our default offset to registry

    ) ;; End progn

  ) ;; End if
  ) ;; End while

  (vla-EndUndoMark acDoc)

  (*error* nil) (princ)

  )

;; Return LWpolyline data in the format.
;; Credit to john.uhden, defun found here: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-polyine-geometry-with-another-polylines-geometry-lisp/m-p/10596684#M419793
;; '((b1 x1 y1)(b2 x2 y2) ... (bn xn yn))
(defun @Plist (E / plist blist)
  (setq ent (entget e))
  (setq plist (mapcar 'cdr (vl-remove-if-not '(lambda (x)(= (car x) 10)) ent)))
  (setq blist (mapcar 'cdr (vl-remove-if-not '(lambda (x)(= (car x) 42)) ent)))
  (setq plist (mapcar 'cons blist plist))
  )

;; Apply the collected data from the @Plist function to another LWpolyline.
;; Credit to john.uhden, defun found here: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-polyine-geometry-with-another-polylines-geometry-lisp/m-p/10596684#M419793
;; where obj is a polyline vla-object
(defun @put_data (obj plist / param)
  (vlax-put obj 'Coordinates (apply 'append (mapcar 'cdr plist)))
  (setq param 0) ;; parameter index
  (repeat (length plist)
    (vla-setbulge obj param (car (nth param plist)))
    (setq param (1+ param))
    )
  )

;; entsel with an object filter.
;; Credit to gile here:
;; https://www.theswamp.org/index.php?PHPSESSID=amuofcfnqe6mf8r4g8n5j4t4h4&topic=34004.msg393324#msg393324
(defun fentsel (msg fltr / ent1)
  (if
    (and
      (setq ent1 (if (and (= (type msg) 'STR) (/= msg ""))
        (entsel msg)
        (entsel)
        )
      )
      (wcmatch (cdr (assoc 0 (entget (car ent1)))) (strcase fltr))
      )
    ent1
    )
  )

 

Edited June 26, 2022 by 3dwannab

[mhupp]

Quote

- I've added a loop to pick more objects for offset after the first one is completed. and error checking to only select offset-able objects.

 

At the end of that loop add  the following line. should fix it.

(vla-Regen acDoc acAllViewports)

 

[3dwannab]

10 hours ago, mhupp said:

 

At the end of that loop add  the following line. should fix it.

(vla-Regen acDoc acAllViewports)

 

 

Thanks, that updates, but if I add it like below the command exits and doesn't loop for some reason.

 

    (setenv "MyOffsetProgram" (vl-princ-to-string offDisStr)) ;; Write our default offset to registry

    (vla-Regen acDoc acAllViewports)

 

Also, I'm trying to change the offset method to vla at the moment but I'll try that and if I have any trouble I'll post back on this.

[3dwannab]

Changed the offset method to vla with the use/help of LeeMacs offset sub routine which allows a selection to be offset.

 

Still having the issue with (vla-Regen acDoc acAllViewports) borking the while loop so the command breaks out instead of asking the user for the next selection set.

 

;; Thread here: https://www.cadtutor.net/forum/topic/75500-offset-delete-fixed-with-associated-hatches-minor-problem-hatch-wont-update/
;;
;; 2022.07.11 - 3dwannab
;; - Added support to recreate Polyline at their offset position. This will preserve
;;   any associative hatches if there any.
;; - Added proper undo handling.
;; - Credit to LeeMac and john.uhden for their functions at the bottom for offsetting and polyline manipulation.
;;
;; USAGE
;; 'ODEL' or 'OFFSET_DELETE'.
;;
;; TO DO
;; - Try get the hatches to update after every offset. The (vla-Regen acDoc acAllViewports) part will break out of the loop.
;;

(defun c:ODEL nil (c:OFFSET_DELETE))

(defun c:OFFSET_DELETE (/ acDoc *error* cordins ent entPlTemp i o offDisStr ptOffside ssOffset ssOrg typ)

  (defun *error* (errmsg)
    (and acDoc (vla-EndUndoMark acDoc))
    (and errmsg
         (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*"))
         (princ (strcat "\n<< Error: " errmsg " >>\n"))
    )
  )

  (vla-StartUndoMark (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object))))

  (setq offDisStr (atof (cond ((getenv "MyOffsetProgram")) ("1")))) ;; Get saved offset from registry or default to 1

  (while

    (if

      (and
        (setq offDisStr (cond ((getdist (strcat "\nOffset distance <" (vl-princ-to-string offDisStr) ">: "))) (offDisStr))) ;; Prompt for distance, if nil use default
        (setq ssOrg (LM:ssget "\nSelect object to offset :" '("_:L" ((0 . "*")))))
        (setq ptOffside (cond ((getpoint "\nSpecify point on side to offset : ")) ((cadr ssOrg)))) ;; Pick a side to offset or use point in entsel
      )

      ;; If selection is valid
      (progn

        (setenv "MyOffsetProgram" (vl-princ-to-string offDisStr)) ;; Write our default offset to registry

        ;; Loop through each entity in the selection set
        (repeat (setq i (sslength ssOrg))
          (if
            (and
              (setq o (vlax-ename->vla-object (ssname ssOrg (setq i (1- i)))))
              (vlax-method-applicable-p o 'offset)
            )

            ;; Begin offsetting objects
            (progn
              (setq e (ssname ssOrg i))
              (setq typ (cdr (assoc 0 (entget e)))) ;; Get the type of object, i.e. POLYLINE, LINE etc

              (setq ssOffset (ssadd))
              (setq ssOffset (ssadd e ssOffset))

              ;; Offset all other items apart from polylines
              (cond
                ((not (wcmatch typ "*POLYLINE")))

                (lmac-offset ssOffset ptOffside offDisStr)

                (entdel (ssname ssOffset i)) ;; Delete original (entdel won't **** the bed if the object is locked)
              ) ;; End cond for all but POLYLINES

              ;; Offset polylines only but recreate them based on the offset polyline verts
              (cond
                ((wcmatch typ "*POLYLINE"))

                (lmac-offset ssOffset ptOffside offDisStr)

                (setq cordins (@Plist (entlast))) ;; Get the coordinates of the offset polyline
                (setq entPlTemp (entlast)) ;; Set the variable for the newly created temporary entity
                ;; Put the properties of the new offset polyline to the original one to preserve
                ;; any associative hatches there may or not be.
                (if entPlTemp
                  (progn
                    (@put_data (vlax-ename->vla-object e) (@Plist entPlTemp))
                    (entdel entPlTemp) ;; Delete the temporary polyline
                  )
                ) ;; End if entPlTemp
              ) ;; End cond for POLYLINES
            ) ;; end progn for offsetting
          )
        ) ;; end repeat for selection set
      ) ;; end progn for T if
    ) ;; End if
  ) ;; End while

  ;; This doesn't really do anything outside here as the hatch updates anyway.
  ;; Having this in the while loop breaks out if the loop so no point it in there either!!
  (vla-Regen acDoc acAllViewports)

  (vla-EndUndoMark acDoc)
  (*error* nil)
  (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)
)

;; Return LWpolyline data in the format.
;; Credit to john.uhden, defun found here: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-polyine-geometry-with-another-polylines-geometry-lisp/m-p/10596684#M419793
;; '((b1 x1 y1)(b2 x2 y2) ... (bn xn yn))
(defun @Plist (E / plist blist)
  (setq ent (entget e))
  (setq plist (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) ent)))
  (setq blist (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) ent)))
  (setq plist (mapcar 'cons blist plist))
)

;; Apply the collected data from the @Plist function to another LWpolyline.
;; Credit to john.uhden, defun found here: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-polyine-geometry-with-another-polylines-geometry-lisp/m-p/10596684#M419793
;; where obj is a polyline vla-object
(defun @put_data (obj plist / param)
  (vlax-put obj 'Coordinates (apply 'append (mapcar 'cdr plist)))
  (setq param 0) ;; parameter index
  (repeat (length plist)
    (vla-setbulge obj param (car (nth param plist)))
    (setq param (1+ param))
  )
)

;; Will Offset a SelSet to the side chosen at distance specified ;;
;; Args:                                                         ;;
;; ss   ~   SelectionSet                                         ;;
;; pt   ~   Point specifying the side to offset                  ;;
;; dis  ~   Distance to Offset                                   ;;
;; Returns:                                                      ;;
;; List of Offset Objects                                        ;;

(defun lmac-offset (ss pt dis / ent obj l)
  (vl-load-com)
  ;; © Lee Mac  ~  25.03.10

  ((lambda (i)

     (cond
       ((not
          (and (eq 'PICKSET (type ss))
               (numberp dis)
               (vl-consp pt)
          )
        )
       )

       ((while (setq ent (ssname ss (setq i (1+ i))))

          (if
            (vlax-method-applicable-p
              (setq obj (vlax-ename->vla-object ent))
              'Offset
            )

            (mapcar
              (function vla-delete)
              (car
                (setq l (append
                          (vl-sort
                            (mapcar
                              (function
                                (lambda (x)
                                  (vlax-invoke obj 'Offset x)
                                )
                              )
                              (list dis (- dis))
                            )

                            (function
                              (lambda (a b)
                                (> (distance pt (vlax-curve-getClosestPointto (car a) pt))
                                   (distance pt (vlax-curve-getClosestPointto (car b) pt))
                                )
                              )
                            )
                          )

                          (cdr l)
                        )
                )
              )
            )
          )
        )
       )
     )
   )
    -1
  )

  (apply (function append) (cdr l))
)

(princ
  (strcat
    "\nOffset_Delete.lsp edited on "
    (menucmd "m=$(edtime,0,DD-MO-yyyy)")
    " by 3dwannab (stephensherry147@yahoo.co.uk) loaded"
    "\nType \"ODEL\" or \"OFFSET_DELETE\" to run Program"
  )
)
(princ)

 

Edited July 10, 2022 by 3dwannab

[mhupp]

I looked at your first code. seems to work fine for me.

 

there was a mistype tho.

(setq entOrg (fentsel (strcat"\nSelect object to offset :\n") "*"))
(setq entOrg (entsel (strcat"\nSelect object to offset :\n") "*"))

 

If their still a problem id suggest simplifying the while to only the offset boundary. then once that's set prompt the user to choose the distance and direction from inside the while.

[3dwannab]

Strange. It doesn't for me in acad 2023.

 

It's fine as there's no regen or vla regen command in that version. The while loop works perfectly but when I try to add a regen the command loop breaks that. Try the lastest code I posted and move the regen into the progn of the if statement. Thanks. 

Edited July 11, 2022 by 3dwannab

[tombu]

The entupd (AutoLISP) function updates the screen image of an object (entity) without having to regen. Saving the value of entlast and using entupd on every entity added after it using entnext is faster when adding polylines than regening even though it adds a few lines of code.

;| TIP1158.LSP: RE.LSP   Regen Entity Cadalyst Oct'95
   (c)1995, Joseph A. St. Ours
   Purpose: Regenerate user selected entities 

Menu Item (put below ID_Regenall in View Menu)
ID_RegEnt    [Re&gen Entity]^C^C^P(if(not C:re)(load "re"));re

***HELPSTRINGS Item
// ===================CUSTOM=========================== //
ID_RegEnt       [Regenerate user selected entities:  RE]
// ==================================================== //

¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤|;
(defun C:RE (/ COUNT ENTITY SET SET_LENGTH)
  (prompt "\nSelect entities to regenerate: ")
  (setq SET (ssget))
  (setq SET_LENGTH (sslength SET))
  (setq COUNT 0)
  (while (< COUNT SET_LENGTH)
    (setq ENTITY (ssname SET COUNT))
    (entupd ENTITY)
    (setq COUNT (1+ COUNT))
  )
  (princ)
); end re.lsp

 

[3dwannab]

Thanks @tombu for helping and also @mhupp. 

 

I'm el stupido. There was bad syntax for the cond section that caused this issue of using the regen command. I only noticed nothing was getting offset when I took this script into work.

 

So the fix is not to be stupid. 

 

I think if the regen command is the last call before the while loops again then it breaks the loop. Where I have it positioned in the code works. Strange.

 

entupd didn't work. 

 

Related thread about hatching not updating: https://www.theswamp.org/index.php?topic=53010.0

 

Here's the finished article:

There seems to be a bug with the offset selection set passed to LeeMacs offset sub routine but it seems hit and miss for some reason. I will test this at work today and see what gives. 

 

 

 

;|

ABOUT
- Offsets by specified distance and deletes the original but in the case of
  Polylines it recreates them. This is to preserve the associative hatches if
  there any.
- Distance remembered through different ACAD sessions. Variable saved to the
  registry.
- Non Polyline code done by user ronjonp here: http://www.cadtutor.net/forum/showthread.php?24646-Offset-and-delete-source&p=699122&viewfull=1#post699122
- Polyline recreation code from here: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-polyine-geometry-with-another-polylines-geometry-lisp/m-p/7134030#M354113
- My thread for help here: https://www.cadtutor.net/forum/topic/75500-offset-delete-fixed-with-associated-hatches-minor-problem-hatch-wont-update/

MY EDITS, BY 3dwannab
2018.03.24
- I've added a loop to pick more objects for offset after the first one is
  completed. and error checking to only select offset-able objects.
- It also doesn't fail if nothings selected.

2022.06.25
- Added support to recreate Polyline as the offset position. This will preserve
  any associative hatches if there any.
- Added proper undo handling.

  2022.07.13
- Fixed the while loop bug and updating of hatches after each offset.

USAGE
'ODEL' or 'OFFSET_DELETE'.

|;

(defun c:ODEL nil (c:OFFSET_DELETE))

(defun c:OFFSET_DELETE (/ acDoc *error* cordins ent entPlTemp i o offDisStr ptOffside ssOffset ssOrg typ)

  (defun *error* (errmsg)
    (and acDoc (vla-EndUndoMark acDoc))
    (and errmsg
         (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*"))
         (princ (strcat "\n<< Error: " errmsg " >>\n"))
    )
  )

  (vla-StartUndoMark (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object))))

  (setq offDisStr (atof (cond ((getenv "MyOffsetProgram")) ("1")))) ;; Get saved offset from registry or default to 1

  (while

    (if

      (and
        (setq offDisStr (cond ((getdist (strcat "\nOffset distance <" (vl-princ-to-string offDisStr) ">: "))) (offDisStr))) ;; Prompt for distance, if nil use default
        (setq ssOrg (LM:ssget "\nSelect object to offset :" '("_:L" ((0 . "*")))))
        (setq ptOffside (cond ((getpoint "\nSpecify point on side to offset : ")) ((cadr ssOrg)))) ;; Pick a side to offset or use point in entsel
      )

      ;; If selection is valid
      (progn

        (setenv "MyOffsetProgram" (vl-princ-to-string offDisStr)) ;; Write our default offset to registry

        ;; Loop through each entity in the selection set
        (repeat (setq i (sslength ssOrg))
          (if
            (and
              (setq o (vlax-ename->vla-object (ssname ssOrg (setq i (1- i)))))
              (vlax-method-applicable-p o 'offset)
            )

            ;; Begin offsetting objects
            (progn
              (setq e (ssname ssOrg i))
              (setq typ (cdr (assoc 0 (entget e)))) ;; Get the type of object, i.e. POLYLINE, LINE etc

              (setq ssOffset (ssadd))
              (setq ssOffset (ssadd e ssOffset))

              ;; Offset all other items apart from polylines
              (cond
                ((not (wcmatch typ "*POLYLINE"))

                 (lmac-offset ssOffset ptOffside offDisStr)

                 (entdel e) ;; Delete original (entdel won't **** the bed if the object is locked)
                ) ;; End cond for all but POLYLINES

                ;; Offset polylines only but recreate them based on the offset polyline verts
                ((wcmatch typ "*POLYLINE")

                 (lmac-offset ssOffset ptOffside offDisStr)

                 (setq cordins (@Plist (entlast))) ;; Get the coordinates of the offset polyline
                 (setq entPlTemp (entlast)) ;; Set the variable for the newly created temporary entity
                 ;; Put the properties of the new offset polyline to the original one to preserve
                 ;; any associative hatches there may or not be.
                 (if entPlTemp
                   (progn
                     (@put_data (vlax-ename->vla-object e) (@Plist entPlTemp))
                     (command "._regen") ;; This litle blitter was the fix to update the hatch. I had also ill formatted the cond part and it was breaking the loop
                     (entdel entPlTemp) ;; Delete the temporary polyline
                   )
                 ) ;; End if entPlTemp
                ) ;; End cond for POLYLINES
              )

              (ssdel e ssOffset) ;; Delete the entity from the selection set at the end

              ; sdfas
            ) ;; end progn for offsetting
          )
        ) ;; end repeat for selection set
      ) ;; end progn for T if
    ) ;; End if
  ) ;; End while

  ;; This doesn't really do anything outside here as the hatch updates anyway.
  ;; Having this in the while loop breaks out if the loop so no point it in there either!!
  ; (vla-Regen acDoc acAllViewports)

  (vla-EndUndoMark acDoc)
  (*error* nil)
  (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)
)

;; Return LWpolyline data in the format.
;; Credit to john.uhden, defun found here: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-polyine-geometry-with-another-polylines-geometry-lisp/m-p/10596684#M419793
;; '((b1 x1 y1)(b2 x2 y2) ... (bn xn yn))
(defun @Plist (E / plist blist)
  (setq ent (entget e))
  (setq plist (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) ent)))
  (setq blist (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) ent)))
  (setq plist (mapcar 'cons blist plist))
)

;; Apply the collected data from the @Plist function to another LWpolyline.
;; Credit to john.uhden, defun found here: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-polyine-geometry-with-another-polylines-geometry-lisp/m-p/10596684#M419793
;; where obj is a polyline vla-object
(defun @put_data (obj plist / param)
  (vlax-put obj 'Coordinates (apply 'append (mapcar 'cdr plist)))
  (setq param 0) ;; parameter index
  (repeat (length plist)
    (vla-setbulge obj param (car (nth param plist)))
    (setq param (1+ param))
  )
)

;; Will Offset a SelSet to the side chosen at distance specified ;;
;; Args:                                                         ;;
;; ss   ~   SelectionSet                                         ;;
;; pt   ~   Point specifying the side to offset                  ;;
;; dis  ~   Distance to Offset                                   ;;
;; Returns:                                                      ;;
;; List of Offset Objects                                        ;;
(defun lmac-offset (ss pt dis / ent obj l)
  (vl-load-com)
  ;; © Lee Mac  ~  25.03.10

  ((lambda (i)

     (cond
       ((not
          (and (eq 'PICKSET (type ss))
               (numberp dis)
               (vl-consp pt)
          )
        )
       )

       ((while (setq ent (ssname ss (setq i (1+ i))))

          (if
            (vlax-method-applicable-p
              (setq obj (vlax-ename->vla-object ent))
              'Offset
            )

            (mapcar
              (function vla-delete)
              (car
                (setq l (append
                          (vl-sort
                            (mapcar
                              (function
                                (lambda (x)
                                  (vlax-invoke obj 'Offset x)
                                )
                              )
                              (list dis (- dis))
                            )

                            (function
                              (lambda (a b)
                                (> (distance pt (vlax-curve-getClosestPointto (car a) pt))
                                   (distance pt (vlax-curve-getClosestPointto (car b) pt))
                                )
                              )
                            )
                          )

                          (cdr l)
                        )
                )
              )
            )
          )
        )
       )
     )
   )
    -1
  )

  (apply (function append) (cdr l))
)
(princ
  (strcat
    "\nOffset_Delete.lsp edited on "
    (menucmd "m=$(edtime,0,DD-MO-yyyy)")
    " by 3dwannab (stephensherry147@yahoo.co.uk) loaded"
    "\nType \"ODEL\" or \"OFFSET_DELETE\" to run Program"
  )
)
(princ)
; (c:ODEL)

 

Edited July 13, 2022 by 3dwannab