Aller au contenu

modification LISP


metacilla

Messages recommandés

Bonjour à tous,

 

j'ai un lisp qui fonctionne correctement mais sur lequel il faudrait faire une petite modification pour laquel je suis totalement bloqué.

 

pour le moment le LISP me sort les coordonnées de l'élément selectionné en 2 textes (X et Y)

serait-il possible, qu'il me les sorte sous une ligne de repère (sur 2 étages x y )?

 

 

lisp

 

;;
;; Commande au clavier: ptdef-xyz_field 
;; 
;; Routine: pddef-xyz_field par Bruno
;;
;; Creation de 3 calques: ID-POINT, ID-XY, ID-Z
;;
;; Dessin d'un point graphique sur ID-POINT (Changer le style de Point eventuellement)
;; Ce point est dessine sur chaque sommet des objets (polyligne par exemple)
;; Champ dynamique (texte) Z relatif au point sur ID-Z
;; Champ dynamique (texte) X & Y relatif au point sur ID-XY
;;
;; Cette routine traite: polyligne, ligne, arc, cercle, bloc, ellipse, spline,
;;


(defun l-coor2l-pt (lst flag / )
 (if lst
   (cons (list (car lst) (cadr lst) (if flag (caddr lst) 0.0))
     (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
   )
 )
)
(defun make_field (pt / obj)
(vlax-put (vla-AddPoint Space (vlax-3d-point pt)) 'layer "Id-Point")
(setq obj (entlast))
(mapcar
	'(lambda (lx)
		(apply
			'(lambda (ins_point value_field att_point txt_height dwg_dir name_style name_layer txt_rot / nw_obj)
				(setq nw_obj
					(vla-addMtext Space
						(vlax-3d-point ins_point)
						0.0
						(strcat
							"%<\\AcObjProp.16.2 Object(%<\\_ObjId "
							(itoa (vla-get-ObjectID (vlax-ename->vla-object obj)))
							value_field
						)
					)
				)
				(mapcar
					'(lambda (pr val)
						(vlax-put nw_obj pr val)
					)
					(list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation)
					(list att_point txt_height dwg_dir ins_point name_style name_layer txt_rot)
				)
			)
			lx
		)
	)
	(list
		(list
			(mapcar '+ pt
         (list
           (- (* (getvar "TEXTSIZE") (cos rtx0)) (* (* (getvar "TEXTSIZE") 0.5) (sin rtx0)))
           (+ (* (getvar "TEXTSIZE") (sin rtx0)) (* (* (getvar "TEXTSIZE") 0.5) (cos rtx0)))
            0.0
         )
       )
			">%).Coordinates \\f \"%lu2%pt1%pr3%ps[X=,]\">%"
			7
			(getvar "TEXTSIZE")
			5
			"Romand-Field"
			"Id-XY"
			rtx
		)
		(list
			(mapcar '+ pt
         (list
           (- (* (getvar "TEXTSIZE") (cos rtx0)) (* (- (* (getvar "TEXTSIZE") 0.5)) (sin rtx0)))
           (+ (* (getvar "TEXTSIZE") (sin rtx0)) (* (- (* (getvar "TEXTSIZE") 0.5)) (cos rtx0)))
           0.0
         )
			)
			">%).Coordinates \\f \"%lu2%pt2%pr3%ps[Y=,]\">%"
			1
			(getvar "TEXTSIZE")
			5
			"Romand-Field"
			"Id-XY"
			rtx
		)
	)
)
)
(defun c:ptdef-xyz_field ( / js htx rtx rtx0 AcDoc Space ncol nw_style dxf_cod n lremov ent ename l_pt l_pr)
(princ "\nChoix d'un objet modèle pour le filtrage: ")
(while
	(null
		(setq js
			(ssget "_+.:E:S"
				(list
					'(0 . "*LINE,POINT,ARC,CIRCLE,SPLINE,ELLIPSE,INSERT")
					(cons 67 (if (eq (getvar "CVPORT") 1) 1 0))
					(cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model"))
				)
			)
		)
	)
	(princ "\nCe n'est pas un objet valable pour cette fonction!")
)
(initget 6)
(setq htx (getdist (getvar "VIEWCTR") (strcat "\nSpécifiez la hauteur du champ <" (rtos (getvar "TEXTSIZE")) ">: ")))
(if htx (setvar "TEXTSIZE" htx))
(if (not (setq rtx (getorient (getvar "VIEWCTR") "\nSpécifiez l'orientation du champ <0.0>: "))) (setq rtx 0.0))
(setq rtx0 (+ (angle '(0 0 0) (getvar "UCSXDIR")) rtx))
(vl-load-com)
(setq
	AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
	Space
	(if (= 1 (getvar "CVPORT"))
		(vla-get-PaperSpace AcDoc)
		(vla-get-ModelSpace AcDoc)
	)
	ncol '(96 174 2)
)
(foreach n '("Id-XY" "Id-Point")
	(cond
		((null (tblsearch "LAYER" n))
			(vlax-put (vla-add (vla-get-layers AcDoc) n) 'color (car ncol))
		)
	)
	(setq ncol (cdr ncol))
)
(cond
	((null (tblsearch "STYLE" "Romand-Field"))
		(setq nw_style (vla-add (vla-get-textstyles AcDoc) "Romand-Field"))
		(mapcar
			'(lambda (pr val)
				(vlax-put nw_style pr val)
			)
			(list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
			(list "romand.shx" 0.0 (/ (* 15.0 pi) 180) 1.0 0.0)
		)
	)
)
 (setq dxf_cod (entget (ssname js 0)))
(initget "Unique Multiple _Single Multiple")
(if (eq (getkword "\nSélection filtrée [unique/Multiple]<M>: ") "Single")
   (setq n -1)
   (setq
     dxf_cod (entget (ssname js 0))
     js
     (ssget "_X" 
       (foreach m (foreach n dxf_cod (if (not (member (car n) '(0 67 410 8 6 62 48 420 70))) (setq lremov (cons (car n) lremov))))
         (setq dxf_cod (vl-remove (assoc m dxf_cod) dxf_cod))
       )
     )
     n -1
   )
 )
(repeat (sslength js)
	(setq ename (vlax-ename->vla-object (ssname js (setq n (1+ n)))) l_pt nil)
   (setq l_pr (list 'StartPoint 'EndPoint 'Center 'InsertionPoint 'Coordinates 'FitPoints))
   (foreach n l_pr
     (if (vlax-property-available-p ename n)
       (setq l_pt
         (if (eq n 'Coordinates)
           (progn
             (append
               (if (eq (vla-get-ObjectName ename) "AcDbPolyline")
                 (l-coor2l-pt (vlax-get ename n) nil)
                 (l-coor2l-pt (vlax-get ename n) T)
               )
               l_pt
             )
           )
           (cons (vlax-get ename n) l_pt)
         )
       )
     )
   )
   (mapcar 'make_field l_pt)
)
(prin1)
)

 

d'avance un grand merci!

Lien vers le commentaire
Partager sur d’autres sites

Bonjour,

Une adaptation du lisp faite sommairement, pas testé en profondeur; des ajustements seront peut être nécessaire.

(defun l-coor2l-pt (lst flag / )
 (if lst
(cons
 	(list
   	(car lst)
   	(cadr lst)
   	(if flag
     	(+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst))
     	(if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
   	)
 	)
 	(l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
)
 )
)
(defun make_field (pt / obj ptlst arr nw_obj)
 (vlax-put (vla-AddPoint Space (vlax-3d-point pt)) 'layer "Id-Point")
 (setq
obj (entlast)
ptlst (append pt (polar pt o_lead d_lead))
arr (vlax-make-safearray vlax-vbdouble (cons 0 (- (length ptlst) 1)))
 )
 (vlax-safearray-fill arr ptlst)
 (setq nw_obj (vla-addMLeader Space (vlax-make-variant arr) 0))
 (vla-put-textstring nw_obj 
(strcat
 	"%<\\AcObjProp Object(%<\\_ObjId "
 	(itoa (vla-get-ObjectID (vlax-ename->vla-object obj)))
 	">%).Coordinates \\f \"%lu6%pt1\">%"
 	"\\P"
 	"%<\\AcObjProp Object(%<\\_ObjId "
 	(itoa (vla-get-ObjectID (vlax-ename->vla-object obj)))
 	">%).Coordinates \\f \"%lu6%pt2\">%"
)
 )
 (vla-put-layer nw_obj "Id-XY")
 (vla-update nw_obj)
)
(defun c:ptdef-xy_field2lead ( / js htx rtx rtx0 pt_lead d_lead o_lead AcDoc Space ncol dxf_cod n lremov ent ename l_pt l_pr)
 (princ "\nChoix d'un objet modèle pour le filtrage: ")
 (while
(null
 	(setq js
   	(ssget "_+.:E:S"
     	(list
       	'(0 . "LINE,MLINE,*POLYLINE,POINT,ARC,CIRCLE,ELLIPSE,INSERT")
       	(cons 67 (if (eq (getvar "CVPORT") 1) 1 0))
       	(cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model"))
     	)
   	)
 	)
)
(princ "\nCe n'est pas un objet valable pour cette fonction!")
 )
 (initget 6)
 (setq htx (getdist (getvar "VIEWCTR") (strcat "\nSpécifiez la hauteur du champ <" (rtos (getvar "TEXTSIZE")) ">: ")))
 (if htx (setvar "TEXTSIZE" htx))
 (if (not (setq rtx (getorient (getvar "VIEWCTR") "\nSpécifiez l'orientation du champ <0.0>: "))) (setq rtx 0.0))
 (setq rtx0 (+ (angle '(0 0 0) (getvar "UCSXDIR")) rtx))
 (initget 1)
 (setq pt_lead (getpoint (getvar "VIEWCTR") "\nSpécifiez l'orientation et la distance type de la ligne de guidage du repère: "))
 (setq d_lead (distance (getvar "VIEWCTR") pt_lead))
 (setq o_lead (angle (getvar "VIEWCTR") pt_lead))
 (vl-load-com)
 (setq
AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
Space
(if (= 1 (getvar "CVPORT"))
 	(vla-get-PaperSpace AcDoc)
 	(vla-get-ModelSpace AcDoc)
)
ncol '(174 2)
 )
 (vla-startundomark AcDoc)
 (foreach n '("Id-XY" "Id-Point")
(cond
 	((null (tblsearch "LAYER" n))
   	(vlax-put (vla-add (vla-get-layers AcDoc) n) 'color (car ncol))
 	)
)
(setq ncol (cdr ncol))
 )
 (setq dxf_cod (entget (ssname js 0)))
 (initget "Unique Multiple _Single Multiple")
 (if (eq (getkword "\nSélection filtrée [unique/Multiple]<M>: ") "Single")
(setq n -1)
(setq
 	dxf_cod (entget (ssname js 0))
 	js
 	(ssget "_X" 
   	(foreach m (foreach n dxf_cod (if (not (member (car n) '(0 67 410 8 6 62 48 420 70))) (setq lremov (cons (car n) lremov))))
     	(setq dxf_cod (vl-remove (assoc m dxf_cod) dxf_cod))
   	)
 	)
 	n -1
)
 )
 (repeat (sslength js)
(setq ename (vlax-ename->vla-object (ssname js (setq n (1+ n)))) l_pt nil)
(setq l_pr (list 'StartPoint 'EndPoint 'Center 'InsertionPoint 'Coordinates 'FitPoints))
(foreach n l_pr
 	(if (vlax-property-available-p ename n)
   	(setq l_pt
     	(if (eq n 'Coordinates)
       	(progn
         	(append
           	(if (eq (vla-get-ObjectName ename) "AcDbPolyline")
             	(l-coor2l-pt (vlax-get ename n) nil)
             	(l-coor2l-pt (vlax-get ename n) T)
           	)
           	l_pt
         	)
       	)
       	(cons (vlax-get ename n) l_pt)
     	)
   	)
 	)
)
(mapcar 'make_field l_pt)
 )
 (vla-regen AcDoc acactiveviewport)
 (vla-endundomark AcDoc)
 (prin1)
)

 

Choisissez un travail que vous aimez et vous n'aurez pas à travailler un seul jour de votre vie. - Confucius

Lien vers le commentaire
Partager sur d’autres sites

Créer un compte ou se connecter pour commenter

Vous devez être membre afin de pouvoir déposer un commentaire

Créer un compte

Créez un compte sur notre communauté. C’est facile !

Créer un nouveau compte

Se connecter

Vous avez déjà un compte ? Connectez-vous ici.

Connectez-vous maintenant
×
×
  • Créer...

Information importante

Nous avons placé des cookies sur votre appareil pour aider à améliorer ce site. Vous pouvez choisir d’ajuster vos paramètres de cookie, sinon nous supposerons que vous êtes d’accord pour continuer. Politique de confidentialité