;;; HATCHB.LSP ver 2.5
;;; Recreates hatch boundary by selecting a hatch
;;; Known problem with some elipses and splines
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2008 JTB World, All Rights Reserved
;;; Website: www.jtbworld.com
;;; E-mail: info@jtbworld.com
;;; 2000-02-12 - First release
;;; 2000-03-27 - Counterclockwise arcs and ellipses fixed
;;; Objects created joined to lwpolyline if possible
;;; Error-handling, undo of command
;;; Can handle PLINETYPE = 0,1,2
;;; 2000-03-30 - Integrating hatchb and hatchb14
;;; Selection of many hatches
;;; Splines supported if closed.
;;; 2001-04-02 - Fixed bug with entmake of line with no Z for r14
;;; 2001-07-31 - Removed an irritating semicolon to enable polylines to be created.
;;; 2001-10-04 - Changed mail and homepage so it's easy to find when new versions comes up.
;;; 2003-02-06 - Minor fix
;;; 2003-02-17 - Area returned if no islands is found since it's not consistant
;;; 2003-05-19 - Fix to take PEDITACCEPT variable used in AutoCAD 2004 into account
;;; 2004-11-05 - Minor bugs fixed
;;; 2006-03-18 - Nothing changed from 2.1 other that it's been confirmed to work with AutoCAD 2007
;;; 2006-05-13 - Create the boundary on the same layer as the hatch using the hbl command and
;;; on current layer/color/linetype using the hb or hatchb command
;;; 2007-02-08 - Fixed a bug with the hbl command
;;; 2008-02-29 - Support for hatches in non WCS thanks to xiaocai
;;; Tested on AutoCAD r14, 2000, 2000i, 2002, 2004, 2005, 2006, 2007, 2008, 2009
;;; should be working on older versions too.
(defun c:hbb
() (hatchb
nil)) ; this line can be commented out if there is an existing command called hb (defun c:hbbl
() (hatchb T
)) ; this line can be commented out if there is an existing command called hbl (defun c:hatchb
() (hatchb1
nil)) (defun hatchb
(hl
/ es blay ed1 ed2 loops1 bptf part
et noe plist ic bul nr ang1 ang2 obj *ModelSpace* *PaperSpace*
space cw errexit undox olderr oldcmdecho ss1 lastent en1 en2 ss lwp
list->variantArray 3dPoint->2dPoint A2k ent i ss2
knot
-list controlpoint
-list kn cn pos xv bot area hst noarea
)
(defun list
->variantArray
(ptsList
/ arraySpace sArray
) vlax-vbdouble
)
)
)
(defun areaOfObject
(en
/ curve area
) area
)
)
nil
area
)
)
)
)
)
)
)
)
(defun 3dPoint
->2dPoint
(3dpt
) )
)
(restore)
)
)
restore undox
*error* errexit
)
)
)
))
)
; Remove for testing purpose
; (setq A2k nil)
; (if (not (equal (assoc 210 ed1) '(210 0.0 0.0 1.0))) (princ "\nHatch not in WCS!")) ;modified by xiaocai
; (setq xv (cdr (assoc 210 ed1))) ;modified by xiaocai
(setq loops1
(cdr (assoc 91 ed1
))) ; number of boundary paths (loops) (setq space
*ModelSpace
*) (setq space
*PaperSpace
*) )
(setq bptf
(cdr (car ed1
))) ; boundary path type flag ((> (boole 1 bptf
2) 0) ; polyline nil
)
)
)
)
(mapcar '3dPoint
->2dPoint plist
) )
)
(setq VLADataPts
(list
->variantArray polypoints
)) (if (/= (nth nr blist
) 0) )
)
)
)
(cons 10 (trans (nth nr plist
) ent
0) );;add trans by xiaocai )
)
(cons 10 (trans (nth nr plist
) ent
0) );;add trans by xiaocai )
)
)
)
)
)
)
(t ; not polyline
((= et 1) ; line
;(setq ed1 (member (assoc 10 (cdr ed1)) ed1))
space
))
)
;(cons 210 xv)
)
)
)
)
)
((= et 2) ; circular arc
;(setq ed1 (member (assoc 10 (cdr ed1)) ed1))
space
))
)
)
)
)
)
)
space
(- 0 ang2)
ang1
)
(- 0 ang1)
ang2
)
))
)
(- 0 ang2)
ang1
)
))
(- 0 ang1)
ang2
)
))
)
)
)
)
)
)
((= et 3) ; elliptic arc
;(setq ed1 (member (assoc 10 (cdr ed1)) ed1))
space
)
)
)
(princ "\nElliptic arc not supported!") )
)
)
((= et 4) ; spline
;(setq ed1 (member (assoc 94 (cdr ed1)) ed1))
)
)
;(list (cons 70 (+ 1 8 (* 2 (cdr (assoc 74 ed1))) (* 4 (cdr (assoc 73 ed1))))))
)
)
)
) ; end cond
) ; end repeat noe
)
)
))
) ; end t
) ; end cond
; Tries to get the area on islands but it's not clear how to know if an island is filled or not
; and if it should be substracted or added to the total area.
; (if (or (= bot 0) (= (boole 1 bot 1) 1)) (setq area (+ area (areaOfObject (entlast)))))
; (if (and (/= hst 1) (/= bot 0) (= (boole 1 bot 1) 0)) (setq area (- area (areaOfObject (entlast)))))
; (princ "\n") (princ bot) (princ "\n") (princ hst) (princ "\n")
; (princ (areaOfObject (entlast)))
) ; end repeat loops1
(if (and (= noarea
nil) (= loops1
1)) (setq area
(+ area
(areaOfObject
(entlast)))) (setq bMoreLoops T
)) )
)
)
(princ "\nTotal Area = ") ))
(restore)
)
;;//////////////////////////////////////////////////////////////////////////////////
;;Create regions to get hatch area.
;;Get hatch area function
;;Written by Faster
(/ ENDENT SS N REGIONS REG1 REGIONS1 REG01 REG02 RTN AREA)
(hatchb nil)
)
)
regions))
)
regions1 regions
)
)
)
)
)
)
)
)
;;//////////////////////////////////////////////////////////////////////////////////
