Visual Lisp : Cadre.lsp
;;; =============================================
;;; Cadre.lsp
;;; Fonctions pour le placement d'un Cadre à divers formats multiples de A4
;;; avec - repérage des marques de pliage et de découpe
;;; - Création du calque et application de sa symbologie
;;;
;;; Auteur : TH
;;; Date création : 12/2009
;;; Date modification : 02/01/2010
;;; Usage :
;;; 1 - (PlaceCadre) : Placement d'un cadre A4 par insertion d'un bloc Dynamique
;;; 2 - Déplacement éventuel et étirement du bloc par contraintes dynamiques en multiples de A4
;;; 3 - (AcheveCadre) : Achève le cadre sélectionné par placement des marques de format et explosion du bloc.
;;; Note : On peut tout à fait attendre la fin du plan pour achever un cadre
;;; On conserve ainsi la possibilité de le redimensionner au besoin.
;;; =============================================
;;; =============================================
;;; PlaceCadre
;;; Placement d'un cadre A4 par insertion d'un bloc Dynamique
;;; Usage : (PlaceCadre) -> Sélection du point d'insertion.
;;; =============================================
(defun c:PlaceCadre(/ pt)
;;; On demande et on mémorise le point d'insertion
(setq pt (getpoint "\nIndiquez le point d'origine (bas_gauche) du cadre : \n"))
(StoSymb) ; Mémorisation du calque et de la symbologie courante
(CreeCalque "MEP-CAR-DES-" "continuous" "20" "111" "1") ; Au cas où... On crée le calque avant de s'en servir.
(ForceSymb "MEP-CAR-DES-") ; Force le calque et la symbologie
;;; On appelle et on place le bloc (un fichier dwg pour un bloc) au point mémorisé
(command "_insert" "Unité:\\Dossier\\Sous_Dossier\\Sous_sous_dossier\\etc...\\etc...\\Cadre_01000.dwg" pt 1 1 0)
(RclSymb) ; Rappel du calque et de la symbologie d'origine
)
;;; =============================================
;;; AcheveCadre
;;; Achève la définition du cadre : place les marques de format et explose le bloc.
;;; Usage : (AcheveCadre) -> sélection du cadre à terminer.
;;; =============================================
(defun c:AcheveCadre(/ e vList obj count) ; On achève bien les chevaux
(vl-load-com)
(setq e (car (entsel "\nSélection du cadre à finaliser\n"))) ; affecte à e l'entité sélectionnée à l'écran
(setq obj (vlax-ename->vla-object e)) ; affecte à obj la correspondance objet de l'entité e
(if (vlax-property-available-p obj 'effectivename) ; si l'objet a un nom effectif c'est un bloc
(progn
(if (= (vlax-get-property obj "effectivename") "Cadre_01000") ; si le nom effectif du bloc est le bon
(progn
(setq pO (cdr (assoc 10 (entget e)))) ; affecte à pO les coordonnées du point d'Origine du Bloc.
(setq xO (car pO)) ; à xO l'abscisse du point d'Origine
(setq yO (cadr pO)) ; à yO l'ordonnée du point d'Origine
(setq pL (getdynprop obj "Largeur")) ; à pL la Largeur
(setq pH (getdynprop obj "Hauteur")) ; à pH la Hauteur
; (princ "xO : ")(princ xO)(princ " , yO : ")(princ yO)(princ " , L : ")(princ pL)(princ " , H : ")(princ pH)(print)
(StoSymb) ; Mémorisation du calque et de la symbologie courante
(ForceSymb "MEP-CAR-DES-") ; Force le calque et la symbologie
(setq vSnap (getvar "osmode")); on mémorise l'accrochage
(setvar "osmode" 16393) ; on désactive l'accrochage
(if (> pL 210) ; Si le cadre est plus large qu'un A4, on marque les plis sur la largeur
(progn
(setq count 1)
(while (> pL (* count 210))
(plie (+ xO (* count 210)) yO 0 1) ; les plis d'en bas
(plie (+ xO (* count 210)) (+ yO pH) 0 -1) ; les plis d'en haut
(setq count (+ count 1))
)
)
)
(if (> pH 297) ; Si le cadre est plus haut qu'un A4, on marque les plis sur la hauteur
(progn
(setq count 1)
(while (> pH (* count 297))
(plie xO (+ yO (* count 297)) 1 0) ; les plis de gauche
(plie (+ xO pL) (+ yO (* count 297)) -1 0) ; les plis de droite
(setq count (+ count 1))
)
)
)
(command "_explode" e) ;;; ON EXPLOSE CE FOUTU BLOC !!!
(setvar "osmode" vSnap) ; on restitue l'accrochage
(RclSymb) ; Rappel du calque et de la symbologie d'origine
)
)
)
)
)
;;; =============================================
;;; Plie
;;; place les marques de pli et de découpe aux coordonnées pX,pY
;;; et dans le sens sX ou sY (1, -1) (avec sX xor sY = 0)
;;; Usage : (Plie pX pY sX sY)
;;; =============================================
(defun Plie (pX pY sX sY / x2 y2 x3 y3 x4 y4)
(if (= 0 sX)
(progn
(setq x2 pX)(setq x3 (- pX 5))(setq x4 (+ pX 5))
(setq y2 (+ (* sY 5) pY))(setq y3 pY)(setq y4 pY)
)
(progn
(setq x2 (+ (* sX 5) pX))(setq x3 pX)(setq x4 pX)
(setq y2 pY)(setq y3 (- pY 5))(setq y4 (+ pY 5))
)
)
(command "polylign" (list pX pY) (list x2 y2) "")
(command "polylign" (list x3 y3) (list x4 y4) "")
)
;;; =============================================
;;; getdynprop
;;; Retourne la valeur de la propriété dynamique propname de l'objet bloc obj
;;; usage : (setq pval (getdynprop entité "NomDeProriété"))
;;; =============================================
(defun getdynprop (obj propname / v vval sal tot i curval)
(setq v (vla-getdynamicblockproperties obj)
vval (vlax-variant-value v)
sal (vlax-safearray->list vval)
tot (length sal)
i 0
)
(while (< i tot)
(if (= (vlax-get-property (nth i sal) "PropertyName") propname)
(progn (setq curval (vlax-get-property (nth i sal) "Value")) (setq i tot))
(setq i (1+ i))
)
)
(if curval (vlax-variant-value curval))
)
;;; =============================================
;;; CreeCalque
;;; Création d'un Calque avec ses attributs
;;; Usage : (CreeCalque "NomDuCalque" "Style de ligne" "Epaisseur" "Couleur" "Tracer")
;;; Tracer = 1 , Ne pas tracer = 0
;;; Epaisseur : 20 pour 0.20 , -1 pour DuCalque , -1 pour Par_Défaut ...
;;; =============================================
(defun CreeCalque (Calque LT Ep Col Plot)
(entmakex
(list
(cons 0 "LAYER")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbLayerTableRecord")
(cons 70 0)
(cons 2 Calque)
(cons 62 (atoi Col))
(cons 6 LT)
(cons 370 (atoi Ep))
(cons 290 (atoi Plot))
)
)
)
;;; =============================================
;;; StoSymb
;;; Mémorisation du calque et de la symbologie courante
;;; Usage : (StoSymb)
;;; =============================================
(defun StoSymb ()
(setq Calque_0 (getvar "clayer"))
(setq Couleur_0 (getvar "cecolor"))
(setq LType_0 (getvar "celtype"))
(setq Epaiss_0 (getvar "celweight"))
)
;;; =============================================
;;; RclSymb
;;; Rappel du calque et de la symbologie d'origine
;;; Usage : (RclSymb)
;;; =============================================
(defun RclSymb ()
(setvar "clayer" Calque_0)
(setvar "cecolor" Couleur_0)
(setvar "celtype" LType_0)
(setvar "celweight" Epaiss_0)
)
;;; =============================================
;;; ForceSymb
;;; Force le calque et la symbologie "DuCalque"
;;; Usage : (ForceSymb "Nom_Du_Calque")
;;; =============================================
(defun ForceSymb (NomCalque)
(setvar "clayer" NomCalque)
(setvar "cecolor" "DuCalque")
(setvar "celtype" "DuCalque")
(setvar "celweight" -1) ; (-1 = "DuCalque")
)