Hello everyone,
I would like the island detection to be set to ignore when the hatching is created.
(defun c:CreateHatchRegion ()
(if (setq objLayer (getvar "clayer")) ; Hole den aktuellen Layer
(progn
;; Hole die Layer-Eigenschaften des aktuellen Layers
(setq currentLayerData (tblsearch "LAYER" objLayer))
(setq currentLayerColor (cdr (assoc 62 currentLayerData))) ; Farbe des aktuellen Layers
;; Suche nach einer Region auf dem aktuellen Layer
(setq sel (ssget "X" (list (cons 8 objLayer) (cons 0 "REGION"))))
;; Wenn eine Region gefunden wurde
(if sel
(progn
(setq ent (ssname sel 0)) ; Wähle das erste gefundene Objekt
;; Erstelle eine SOLID-Schraffur auf der Region
(command "_.hatch" "SOLID" ent "")
;; Hole die zuletzt erstellte Schraffur
(if (setq lastHatch (entlast))
(progn
;; Setze die Transparenz auf 90%
(command "_.CHPROP" lastHatch "" "_transparency" "90" "")
)
)
;; Generiere den neuen Layernamen (aktueller Layer + "_Schraffur")
(setq newLayer (strcat objLayer "_Schraffur"))
;; Überprüfe, ob der neue Layer bereits existiert
(if (not (tblsearch "LAYER" newLayer)) ; Wenn der Layer nicht existiert
(progn
;; Erstelle den Layer mit den gleichen Attributen wie der aktuelle Layer
(command "._LAYER" "_M" newLayer "_Color" currentLayerColor "" "")
)
)
;; Setze den Layer der Schraffur auf den neuen Layer
(command "_.CHPROP" lastHatch "" "_Layer" newLayer "")
(princ "\nSchraffur mit Transparenz und dem neuen Layer erstellt.")
)
)
(princ "\nKeine Region auf dem aktuellen Layer gefunden.")
)
(princ "\nKein aktueller Layer gefunden.")
)
(princ) ; Beende die Ausgabe
)
Is this also possible with this code where a region is created.
(Orginal code: Union polylines; Stefan M. January 9, 2014
;Union polylines
;Stefan M. 09.01.2014 (angepasst für aktiven Layer, Linientyp und Farbe)
(defun c:UNIP ( / *error* i lst ms r1 reg ss sysvar prop obj reg1 op not_reg)
(or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
(setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
(vla-startundomark acDoc)
(setq sysvar (mapcar 'getvar '(peditaccept draworderctl cmdecho)))
(defun *error* (msg)
(and
msg
(not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(mapcar 'setvar '(peditaccept draworderctl cmdecho) sysvar)
(vla-endundomark acDoc)
(princ)
)
(if
(setq ss (ssget ":L" '((0 . "*POLYLINE,CIRCLE,REGION"))))
(progn
; Verwendet aktiven Layer, Linientyp und Farbe
(setq prop (list
(getvar "clayer") ; Aktiver Layer
(getvar "celtype") ; Aktiver Linientyp
(getvar "cecolor") ; Aktive Farbe
))
(repeat (setq i (sslength ss))
(setq i (1- i)
obj (vlax-ename->vla-object (ssname ss i))
)
(if
(eq (vla-get-ObjectName obj) "AcDbRegion")
(setq reg1 (cons obj reg1))
(setq lst (cons obj lst))
)
)
(if lst
(foreach x lst
(if
(and
(not (eq (vla-get-objectname x) "AcDbCircle"))
(eq (vla-get-closed x) :vlax-false)
)
(progn
(setq op T)
(vla-put-closed x :vlax-true)
)
(setq op nil)
)
(if
(not (vl-catch-all-error-p (setq r1 (vl-catch-all-apply 'vlax-invoke (list ms 'AddRegion (list x))))))
(progn
(setq reg (cons (car r1) reg))
(vla-delete x)
)
(progn
(if op (vla-put-closed x :vlax-false))
(setq not_reg (cons x not_reg))
)
)
)
)
(setq reg (append reg reg1))
(if
(setq r1 (car reg))
(progn
(foreach x (cdr reg) (vlax-invoke r1 'boolean acunion x))
(mapcar '(lambda (p v) (vlax-put r1 p v))
'(Layer LineType Color)
prop
)
(setq
lst (apply
'append
(mapcar
'(lambda (a)
(if
(listp a)
(mapcar 'vlax-vla-object->ename a)
(list (vlax-vla-object->ename a))
)
)
(mapcar
'(lambda (e / p)
(if (eq (vla-get-objectname e) "AcDbRegion")
(progn
(setq p (vlax-invoke e 'explode))
(vla-delete e)
p
)
e
)
)
(vlax-invoke r1 'explode)
)
)
)
)
(vla-delete r1)
(setq ss (ssadd))
(foreach x lst (if (not (eq (cdr (assoc 1 (entget x))) "CIRCLE")) (ssadd x ss)))
(if
(< 1 (sslength ss))
(progn
(mapcar 'setvar '(peditaccept draworderctl cmdecho) '(1 0 0))
(command "_pedit" "_m" ss "" "_j" "" "")
)
)
)
)
)
)
(*error* nil)
(princ)
)
Thank you very much, Tom
