I have a routine that draws demolition hatching, basically it draws a boundary around objects and the offsets it and hatches that boundary. It is a bit more than what you want as it work with blocks, circles, arc, lines and plines, but you can probably modify this down to work with just plines.
This version will work with plines with arcs in them, but it will only run on the Windows version of AutoCAD, not the Mac version.
;********************************************************************************************************************************************
;* FD.lsp *
;* Fast Demolition *
;* Quickly adds demolition hatching by selecting objects *
;* *
;* Version 3.0 *
;* Chris Wade *
;* 12/01/2014 *
;* *
;* - Complete rewrite. *
;* - Faster drawing of demolition hatching. *
;* - Hatching is now more reliable. *
;* - Hatching now only covers what is needed. *
;* *
;* Version 2.0 *
;* Chris Wade *
;* 08/04/2011 *
;* - Completely rewritten from scratch. *
;* *
;********************************************************************************************************************************************
(defun c:FD (/ *thisdrawing* *ACAD_LAYERS* Ct SS Obj ObjEnt Obj1 Obj2 Obj1Ent Obj2Ent Obj1End Obj2End Obj3 Obj3Ent Obj4 Obj4Ent Obj7 Obj7Ent StopLoop Tst h_ss f_SS L_SS fh_SS retCoordA retCoordB TM)
(vl-load-com)
;Supporting Functions
;;-----------------------=={ Outline Objects }==-----------------------;;
;; ;;
;; This program enables the user to generate one or more closed ;;
;; polylines or regions outlining all objects in a selection. ;;
;; ;;
;; Following a valid selection, the program calculates the overall ;;
;; rectangular extents of all selected objects and constructs a ;;
;; temporary rectangular polyline offset outside of such extents. ;;
;; ;;
;; Using a point located within the offset margin between the extents ;;
;; of the selection and temporary rectangular frame, the program then ;;
;; leverages the standard AutoCAD BOUNDARY command to construct ;;
;; polylines and/or regions surrounding all 'islands' within the ;;
;; temporary bounding frame. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2014 - www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.0 - 2014-11-30 ;;
;; ;;
;; First release. ;;
;;----------------------------------------------------------------------;;
(defun c:outline ( / *error* sel )
(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(if (setq sel (ssget))
(progn
(LM:startundo (LM:acdoc))
(LM:outline sel)
(LM:endundo (LM:acdoc))
)
)
(princ)
)
;; Outline Objects - Lee Mac
;; Attempts to generate a polyline outlining the selected objects.
;; sel - [sel] Selection Set to outline
;; Returns: [sel] A selection set of all objects created
(defun LM:outline ( sel / app are box cmd dis enl ent lst obj rtn tmp )
(if (setq box (LM:ssboundingbox sel))
(progn
(setq app (vlax-get-acad-object)
dis (/ (apply 'distance box) 20.0)
lst (mapcar '(lambda ( a o ) (mapcar o a (list dis dis))) box '(- +))
are (apply '* (apply 'mapcar (cons '- (reverse lst))))
dis (* dis 1.5)
ent
(entmakex
(append
'( (000 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(090 . 4)
(070 . 1)
)
(mapcar '(lambda ( x ) (cons 10 (mapcar '(lambda ( y ) ((eval y) lst)) x)))
'( (caar cadar)
(caadr cadar)
(caadr cadadr)
(caar cadadr)
)
)
)
)
)
(apply 'vlax-invoke
(vl-list* app 'zoomwindow
(mapcar '(lambda ( a o ) (mapcar o a (list dis dis 0.0))) box '(- +))
)
)
(setq cmd (getvar 'cmdecho)
enl (entlast)
rtn (ssadd)
)
(while (setq tmp (entnext enl)) (setq enl tmp))
(setvar 'cmdecho 0)
(command
"_.-boundary" "_a" "_b" "_n" sel ent "" "_i" "_y" "_o" "_p" "" "_non"
(trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0))) 0 1) ""
)
(while (< 0 (getvar 'cmdactive)) (command ""))
(entdel ent)
(while (setq enl (entnext enl))
(if (and (vlax-property-available-p (setq obj (vlax-ename->vla-object enl)) 'area)
(equal (vla-get-area obj) are 1e-4)
)
(entdel enl)
(ssadd enl rtn)
)
)
(vla-zoomprevious app)
(setvar 'cmdecho cmd)
(if (> (sslength rtn) 0);Code added by Chris Wade to return nill if there are no objects
rtn
nil
)
)
)
)
;; Selection Set Bounding Box - Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; s - [sel] Selection set for which to return bounding box
(defun LM:ssboundingbox ( s / a b i m n o )
(repeat (setq i (sslength s))
(if
(and
(setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
(vlax-method-applicable-p o 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
)
(setq m (cons (vlax-safearray->list a) m)
n (cons (vlax-safearray->list b) n)
)
)
)
(if (and m n)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
)
)
;; Start Undo - Lee Mac
;; Opens an Undo Group.
(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)
;; End Undo - Lee Mac
;; Closes an Undo Group.
(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)
;; Active Document - Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
(vl-load-com) (princ)
;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;
;End of Supporting Functions
(setq *thisdrawing* (vla-get-activedocument (vlax-get-acad-object))
*ACAD_LAYERS* (vla-get-layers *thisdrawing*)
)
(vla-startundomark *thisdrawing*)
(setq Scale (* 0.5 (getvar "Dimscale"))
Odist (* 0.0625 (getvar "Dimscale"))
)
(while (not StopLoop)
(while (not SS)
(princ "\rSelect objects to demolish: ")
(setq SS (ssget))
)
(setq Tm (getvar "Tilemode"))
(if (= Tm 0)
(setvar "tilemode" 1)
)
(setq Ct 0
SelectionLength (sslength SS)
h_SS (ssadd)
f_SS (ssadd)
)
(while (and (/= SS nil) (< Ct SelectionLength));Process open Plines & Blocks first
(setq Obj (vlax-ename->vla-object (ssname SS Ct))
ObjName (vla-get-objectname Obj)
)
; (princ "\n")(princ ObjName)
(cond
((= ObjName "AcDbPolyline")
(cond
((= (vla-get-closed Obj) :vlax-false)
(progn
(vlax-invoke Obj 'Offset ODist)
(setq Obj1Ent (entlast)
Obj1 (vlax-ename->vla-object Obj1Ent)
)
(vlax-invoke Obj 'Offset (* ODist -1))
(setq Obj2Ent (entlast)
Obj2 (vlax-ename->vla-object Obj2Ent)
)
(setq Obj1End (vlax-curve-getendpoint Obj1)
Obj2End (vlax-curve-getendpoint Obj2)
)
(vla-put-constantwidth Obj1 0)
(vla-put-constantwidth Obj2 0)
(command "._pline" Obj1End Obj2End "")
(setq Obj4Ent (entlast))
(setq OldPeditAccept (getvar "peditaccept"))
(setvar "peditaccept" 1)
(command "._pedit" "M" Obj4Ent Obj1Ent Obj2Ent "" "j" "0" "c" "")
(setvar "peditaccept" OldPeditAccept)
(setq Obj2Ent (entlast))
(setq Obj2 (vlax-ename->vla-object Obj4Ent))
(ssadd Obj2Ent h_SS)
(if (not (vlax-erased-p Obj1))
(vla-delete Obj1)
)
)
)
(T
(setq Obj7Ent (ssname SS Ct)
Obj7 (vlax-ename->vla-object Obj7Ent)
)
(vlax-invoke Obj7 'Offset (* ODist -1))
(setq Obj2Ent (entlast)
Obj2 (vlax-ename->vla-object Obj2Ent)
)
(ssadd Obj2Ent h_SS)
)
)
)
((= ObjName "AcDbLine")
(vlax-invoke Obj 'Offset ODist)
(setq Obj1Ent (entlast)
Obj1 (vlax-ename->vla-object Obj1Ent)
)
(vlax-invoke Obj 'Offset (* ODist -1))
(setq Obj2Ent (entlast)
Obj2 (vlax-ename->vla-object Obj2Ent)
)
(setq Obj1End (vlax-curve-getendpoint Obj1)
Obj2End (vlax-curve-getendpoint Obj2)
)
(command "._pline" Obj1End Obj2End "")
(setq Obj4Ent (entlast))
(setq OldPeditAccept (getvar "peditaccept"))
(setvar "peditaccept" 1)
(command "._pedit" "M" Obj4Ent Obj1Ent Obj2Ent "" "j" "0" "c" "")
(setvar "peditaccept" OldPeditAccept)
(setq Obj2Ent (entlast))
(setq Obj2 (vlax-ename->vla-object Obj4Ent))
(ssadd Obj2Ent h_SS)
(if (not (vlax-erased-p Obj1))
(vla-delete Obj1)
)
)
(T
(ssadd (ssname SS Ct) f_SS)
)
)
(setq ct (+ ct 1))
);End While
(if (/= f_SS nil)
(progn
(if (> (sslength f_ss) 0)
(progn
(setq L_ss (LM:Outline f_SS)
ct 0)
(if (/= L_ss nil)
(progn
(while (< Ct (sslength L_ss))
(setq Obj7Ent (ssname L_ss ct)
Obj7 (vlax-ename->vla-object Obj7Ent)
)
(vlax-invoke Obj7 'Offset (* ODist -1))
(setq Obj2Ent (entlast)
Obj2 (vlax-ename->vla-object Obj2Ent)
)
(ssadd Obj2Ent h_SS)
(if (not (vlax-erased-p Obj7))
(vla-delete Obj7)
)
(setq Ct (+ ct 1))
)
)
)
)
)
)
)
(if (> (sslength h_SS) 0)
(progn
(setq fh_SS (LM:Outline h_SS))
(if (/= fh_SS nil)
(progn
(command "._-bhatch" "s" fh_SS "" "P" "Ansi31" scale "0" "")
(setq Obj3Ent (entlast)
Obj3 (vlax-ename->vla-object Obj3Ent)
)
(cond
((not (tblsearch "LAYER" "$DEMOHATCH"))
(setq NewLayer (vla-add *ACAD_LAYERS* "$DEMOHATCH"))
(vla-put-color NewLayer 8)
(cond
((= (getvar "pstylemode") 0)
(vla-put-plotstylename NewLayer "highlight")
)
)
)
)
(vla-put-layer Obj3 "$DEMOHATCH")
(command "._erase" fh_SS "")
)
(progn
(alert "Demolition Hatching for selected objects could not be drawn automatically")
)
)
(command "._erase" h_SS "")
)
(progn
(alert "Demolition Hatching for selected objects could not be drawn automatically")
)
)
(if (/= (getvar "Tilemode") TM)
(setvar "tilemode" tm)
)
(setq SS nil)
)
(vla-endundomark *thisdrawing*)
(princ)
)
As usual, I believe that I have credited any code that is not my own, but if you see some of your code in here that isn't credited, please let me know.
