Code:
(vl-load-com); Macht einen Layer aktuell
(defun SET-LAYER (NAME / RETVAL)
(vla-put-activelayer
(CURRENT-DOCUMENT)
(setq RETVAL (vla-item (DOCUMENT-LAYERS) NAME))
) ;_ Ende von vla-put-ActiveLayer
RETVAL
) ;_ Ende von defun
; gibt das Vla-Object zu einem
; Layernamen zurück
(defun layer-object(name / result)
(vlax-for layer(document-layers)
(if
(=(strcase name)
(strcase(vla-get-name layer))
)
(setq result layer)
)
)
result
)
;; Erzeugt einen neuen Layer
;; Props ist 'ne Liste aus Eigenschaftswerten
;| z.B.
(list (cons 'COLOR Integer) -> Integer = Farbnummer
(cons 'LINETYPE Linientypstring) -> String der einen existierenden Linientyp benennt
(cons 'PLOTTABLE Druckbar-Flag) -> bestimmt den Druck-Status des Layers 0 = Nicht druckbar, -1 = druckbar
(cons 'LINEWEIGHT IntegerFlag) -> Linienstärkenvorgabe für den Layer von 0 bis 211 und -1 = VonLayer -2 = VonBlock -3 = Vorgabe
) ;_ Ende von list
|;
;; Es finden keinerlei Prüfungen auf Gültigkeit statt!!!
;|
Beispiel:
(CREATE-IF-NOT-AND-SET "HaselDasel" (list (cons 'COLOR 3)(cons 'LINETYPE "CONTINUOUS")(cons 'PLOTTABLE -1)(cons 'LINEWEIGHT -1)))
oder
(CREATE-IF-NOT-AND-SET "HaselDasel" nil) wenn die Eigenschaften egal sind
|;
(defun CREATE-IF-NOT-AND-SET (NAME PROPS / NEWLAYER RETVAL)
(if
(not
(member (strcase NAME)
(mapcar (function (lambda (X) (strcase X))) (LAYERLIST))
) ;_ Ende von member
) ;_ Ende von not
(progn
(setq NEWLAYER
(vla-add (DOCUMENT-LAYERS) NAME)
) ;_ Ende von setq
(if props
(foreach PROP PROPS
(vlax-put-property
NEWLAYER
(car PROP)
(cdr PROP)
) ;_ Ende von vlax-put-property
) ;_ Ende von foreach
)
(setq retval (set-layer NAME))
) ;_ Ende von progn
(setq retval (set-layer NAME))
) ;_ Ende von if
retval
) ;_ Ende von defun
(defun LAYERLIST (/ RETVAL)
(vlax-for FOR-ITEM (DOCUMENT-LAYERS)
(setq RETVAL (cons (vla-get-name
FOR-ITEM
) ;_ Ende von vla-get-name
RETVAL
) ;_ Ende von cons
) ;_ Ende von setq
) ;_ Ende von vlax-for
RETVAL
) ;_ Ende von defun
; Ermittelt den aktuellen Layer
(defun get-current-layer( / )
(vla-get-activelayer
(current-document)
)
)
; Gibt die Layer-Collection zurück
(defun document-layers( / )
(vla-get-layers
(current-document)
)
)
; gibt die aktuelle Zeichnung zurück
(defun current-document( / )
(vla-get-activedocument
(vlax-get-acad-object)
)
)
(defun C:BOESCH (/ BOESCH_ERR OECH OBM EN1 EN2 D SS
SSNEU I EN ENT INSP PT2 AL PT ANG
J
)
(setq OLDLAYER (getvar "CLAYER")
CLAYER "0_Li_Gr_018"
) ;_ Ende von setq
(CREATE-IF-NOT-AND-SET CLAYER (list (cons 'COLOR 3)(cons 'LINETYPE "CONTINUOUS")(cons 'PLOTTABLE -1)(cons 'LINEWEIGHT -1)))
(defun *BOESCH_ERR* (S) ; Fehlerroutine
(setq *ERROR* OERR)
(command "_.UNDO" "_End")
(setvar "CMDECHO" OECH)
(setvar "BLIPMODE" OBM)
(princ)
) ;_ Ende von defun
(defun GETENT (TXT / EN)
(princ TXT)
(initget " ")
(while (not (setq EN (entsel "")))
(initget " ")
) ;_ Ende von while
EN
) ;_ Ende von defun
;; (getd <txt> )
;; erweiterte (getdist) Funktion
;;
(defun GETD (TXT / CONT PT1 PT2 D)
(setq CONT t)
(while CONT
(initget 128)
(setq PT1 (getpoint TXT))
(cond
((null PT1) (setq CONT NIL))
((= 'list (type PT1))
(setq PT2
(getpoint PT1
"\nZweiter Punkt (nach Links = neg. Abstand): "
) ;_ Ende von getpoint
) ;_ Ende von setq
(if PT2
(progn
(setq D (distance PT1 PT2))
(if (> (car PT1) (car PT2))
(setq D (- D))
) ;_ Ende von if
(setq CONT NIL)
) ;_ Ende von progn
) ;_ Ende von if
)
((setq D (distof PT1))
(setq CONT NIL)
)
) ;_ Ende von cond
) ;_ Ende von while
D
) ;_ Ende von defun
(setq OERR *ERROR*
*ERROR* *BOESCH_ERR*
OECH (getvar "CMDECHO")
OBM (getvar "BLIPMODE")
) ;_ Ende von setq
(setvar "CMDECHO" 0)
(setvar "BLIPMODE" 0)
(setq EN1 (GETENT "\nObere Grenzkante picken: "))
(if (/= "" EN1)
(progn
(redraw (car EN1) 3)
(setq EN2 (GETENT "\nUntere Grenzkante picken: "))
(if (/= "" EN2)
(progn
(redraw (car EN2) 3)
(setq D
(GETD
"\nSchraffurabstand (neg. Abstand wechselt die Richtung): "
) ;_ Ende von getd
) ;_ Ende von setq
(if D
(progn
(princ "\nErzeuge Boeschungsschraffur...")
(if (= 0 (getvar "UNDOCTL"))
(command "_.UNDO" "_All")
) ;_ Ende von if
(command "_.UNDO" "_End" "_.UNDO" "_Group")
;; Blockdefinition fuer temp. Linienbloecke erzeugen:
(entmake '((0 . "BLOCK")
(2 . "BOESCH")
(10 0.0 0.0 0.0)
(70 . 0)
)
) ;_ Ende von entmake
(entmake
(list
'(0 . "LINE")
'(10 0.0 0.0 0.0)
(if (minusp D)
'(11 0.0 0.0001 0.0)
'(11 0.0 -0.0001 0.0)
) ;_ Ende von if
) ;_ Ende von list
) ;_ Ende von entmake
(entmake '((0 . "ENDBLK")))
;; temp. Linienbloecke einfuegen:
(command "_.MEASURE" EN1 "_Block" "BOESCH" "_Y" (abs D))
(setq SS (ssget "_P")
SSNEU (ssadd)
I 0
) ;_ Ende von setq
;; temp. Linienbloecke explodieren:
(while (setq EN (ssname SS I))
(command "_.EXPLODE" EN)
(setq EN (entlast)
SSNEU (ssadd EN SSNEU)
I (1+ I)
) ;_ Ende von setq
) ;_ Ende von while
(setq I 0
J 1
SS (ssadd)
SSD (ssadd)
) ;_ Ende von setq
;; Linien dehnen und kuerzen:
(command "_.EXTEND" EN2 "")
(while (setq EN (ssname SSNEU I))
(setq I (1+ I)
ENT (entget EN)
PT1 (cdr (assoc 10 ENT))
PT2 (cdr (assoc 11 ENT))
) ;_ Ende von setq
(command (list EN (trans PT2 0 1)))
(if (equal PT2
(setq PT3
(cdr (assoc 11 (setq ENT (entget EN '("*")))))
) ;_ Ende von setq
0.00001
) ;_ Ende von equal
(ssadd EN SSD)
(if (= J 1)
(progn
(ssadd EN SS)
(setq J 0)
) ;_ Ende von progn
(setq J (1+ J))
) ;_ Ende von if
) ;_ Ende von if
) ;_ Ende von while
(command)
(setq I 0)
(while (setq EN (ssname SS I))
(setq ENT (entget EN)
PT1 (cdr (assoc 10 ENT))
PT2 (cdr (assoc 11 ENT))
D (/ (distance PT1 PT2) 2)
ANG (angle PT1 PT2)
PT2 (polar PT1 ANG D)
ENT (subst (cons 11 PT2) (assoc 11 ENT) ENT)
I (1+ I)
) ;_ Ende von setq
(entmod ENT)
) ;_ Ende von while
(setq I 0)
(while (setq EN (ssname SSD I))
(entdel EN)
(setq I (1+ I))
) ;_ Ende von while
(command "_.-GROUP" "_Create" "*" "Boeschung" SSNEU "")
(command "_.UNDO" "_End")
) ;_ Ende von progn
) ;_ Ende von if
) ;_ Ende von progn
) ;_ Ende von if
) ;_ Ende von progn
) ;_ Ende von if
(if (and EN1 (/= "" EN1))
(redraw (car EN1) 4)
) ;_ Ende von if
(if (and EN2 (/= "" EN2))
(redraw (car EN2) 4)
) ;_ Ende von if
(setvar "CMDECHO" OECH)
(setvar "BLIPMODE" OBM)
(setq *ERROR* OERR)
(CREATE-IF-NOT-AND-SET OLDLAYER nil)
(princ)
) ;_ Ende von defun
Foren auf CAD.de (alle Foren)
| 
