modification LISP

metacilla · le 10 juillet 2018

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!

bonuscad · le 11 juillet 2018

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)
)

metacilla · le 12 juillet 2018

Merci beaucoup,

T'es un Chef!

Mais si je peux faire mon Monsieur RELOU, serait il possible que les lignes de repères respect le SCU courant et non le général?

d'avance merci!!! :D

Connexion

modification LISP

Messages recommandés

metacilla

bonuscad

metacilla

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Forums

Naviguer

Activité

Information importante