Ok, I have resolved most of the bugs, but I am still having some issues where empty spaces are created when there are overlapping areas, please see attached image for example.
Here is the current code:
;********************************************************************************************************************************************
;* 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)
)
