(defun c:s2h ( / *error* acDoc ms isErr catch vla nam layer color echo ss i ent e lay col id lst reg crt)
(setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object))
ms (vla-get-ModelSpace acDoc)
isErr vl-catch-all-error-p
catch vl-catch-all-apply
vla vlax-ename->vla-object
nam vlax-vla-object->ename
layer (getvar 'clayer)
color (getvar 'cecolor)
echo (getvar 'cmdecho)
)

(vla-StartUndoMark acDoc)
(setvar 'cmdecho 0)

(defun *error* (msg)
(vla-EndUndoMark acDoc)
(setvar 'clayer layer)
(setvar 'cecolor color)
(if msg (command "UNDO" "1"))
(setvar 'cmdecho echo)
(princ)
)

(if
(setq ss (ssget '((0 . "SOLID"))))
(progn
(repeat (setq i (sslength ss))
(setq ent (entget (setq e (ssname ss (setq i (1- i)))))
lay (cdr (assoc 8 ent))
col (cond ((cdr (assoc 62 ent))) (256))
id (cons lay col)
)
(if
(not (isErr (setq crt (catch 'vlax-invoke (list ms 'addRegion (list (vla e)))))))
(if
(member id lst)
(catch 'vla-Boolean (list (nth (vl-position id lst) reg) acUnion (car crt)))
(setq lst (cons id lst)
reg (cons (car crt) reg)
)
)
)
(vla-delete (vla e))
)
(mapcar
(function
(lambda (obj prop)
(setvar 'clayer (car prop))
(setvar 'cecolor (itoa (cdr prop)))
(command "hatch" "solid" (nam obj) ""
"erase" (nam obj) ""
)
)
)
reg
lst
)
)
)
(*error* nil)
(princ)
)
(c:s2h)

Advertisements