Des champs avec ligne de rappel

[bonuscad]

Bonjour,

 

Les lignes de rappel, entité LEADER, permettent d’insérer des champs mais malheureusement la localisation du départ de la ligne de rappel n'est pas disponible.

 

Je vous propose donc d'écrire les coordonnées avec une façon un peu similaire à une ligne de rappel.

Le programme fonctionne dans tout les SCU, mais retournera la valeur des coordonnées TOUJOURS depuis le SCG.

 

(defun c:coord-xy_field ( / AcDoc Space pt_pos pt_field htx rtx ncol ocs op dlt1 dlt2 obj js nw_obj l_max lst_pt p1 p2 p3 nw_pl)
 (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)
   )
 )
 (while (setq pt_pos (getpoint "\nPosition à repérer?: "))
   (initget 9)
   (setq pt_field (getpoint pt_pos "\nEmplacement du texte?: "))
   (initget 6)
   (setq htx (getdist pt_field (strcat "\nSpécifiez la hauteur du champ <" (rtos (getvar "TEXTSIZE")) ">: ")))
   (if htx (setvar "TEXTSIZE" htx))
   (if (not (setq rtx (getorient pt_field "\nSpécifiez l'orientation du champ <0.0>: "))) (setq rtx 0.0))
   (setq
     ncol '(131 160)
     ocs (trans '(0.0 0.0 1.0) 1 0 T)
     op (if (and (> (angle pt_pos pt_field) (* pi 0.5)) (<= (angle pt_pos pt_field) (* 1.5 pi))) T nil)
     dlt1
     (list
       ((if op + -) (* (getvar "TEXTSIZE") (cos rtx)) (* (* (getvar "TEXTSIZE") 0.5) (sin rtx)))
       ((if op - +) (* (getvar "TEXTSIZE") (sin rtx)) (* (* (getvar "TEXTSIZE") 0.5) (cos rtx)))
       0.0
     )
     dlt2
     (list
       ((if op + -) (* (getvar "TEXTSIZE") (cos rtx)) (* (- (* (getvar "TEXTSIZE") 0.5)) (sin rtx)))
       ((if op - +) (* (getvar "TEXTSIZE") (sin rtx)) (* (- (* (getvar "TEXTSIZE") 0.5)) (cos rtx)))
       0.0
     )
   )
   (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" "Coord-Field"))
       (setq nw_style (vla-add (vla-get-textstyles AcDoc) "Coord-Field"))
       (mapcar
         '(lambda (pr val)
           (vlax-put nw_style pr val)
         )
         (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
         (list (strcat (getenv "windir") "\\fonts\\arial.ttf") 0.0 (/ (* 15.0 pi) 180) 1.0 0.0)
       )
     )
   )
   (vlax-put (vla-AddPoint Space (vlax-3d-point (trans pt_pos 1 0))) 'layer "Id-Point")
   (setq obj (entlast) js (ssadd))
   (mapcar
     '(lambda (lx)
       (apply
         '(lambda (ins_point value_field att_point txt_height dwg_dir v_norm txt_rot name_style name_layer / 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
               )
             )
             js (ssadd (entlast) js)
           )
           (mapcar
             '(lambda (pr val)
               (vlax-put nw_obj pr val)
             )
             (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'Normal 'Rotation 'StyleName 'Layer)
             (list att_point txt_height dwg_dir ins_point v_norm txt_rot name_style name_layer)
           )
         )
         lx
       )
     )
     (list
       (list
         (trans (if op (mapcar '- pt_field dlt1) (mapcar '+ pt_field dlt1)) 1 0)
         ">%).Coordinates \\f \"%lu2%pt1%pr3%ps[X= ,]\">%"
         (if op 9 7)
         (getvar "TEXTSIZE")
         5
         ocs
         rtx
         "Coord-Field"
         "Id-XY"
       )
       (list
         (trans (if op (mapcar '- pt_field dlt2) (mapcar '+ pt_field dlt2)) 1 0)
         ">%).Coordinates \\f \"%lu2%pt2%pr3%ps[Y= ,]\">%"
         (if op 3 1)
         (getvar "TEXTSIZE")
         5
         ocs
         rtx
         "Coord-Field"
         "Id-XY"
       )
     )
   )
   (setq l_max nil)
   (foreach n (append (textbox (list (assoc 1 (entget (ssname js 0))))) (textbox (list (assoc 1 (entget (ssname js 1)))))) (setq l_max (cons (apply 'max n) l_max)))
   (setq
     l_max (apply 'max l_max)
     lst_pt
     (list
       (trans pt_pos 1 ocs)
       (trans pt_field 1 ocs)
       (trans (setq p1 (polar pt_field (+ rtx (* 0.5 pi)) (* 2.0 (getvar "TEXTSIZE")))) 1 ocs)
       (trans (setq p2 (polar p1 (if op (+ pi rtx) rtx) (+ l_max (* (getvar "TEXTSIZE") 3.0)))) 1 ocs)
       (trans (setq p3 (polar p2 (- rtx (* 0.5 pi)) (* 4.0 (getvar "TEXTSIZE")))) 1 ocs)
       (trans (polar p3 (if op rtx (+ pi rtx)) (+ l_max (* (getvar "TEXTSIZE") 3.0))) 1 ocs)
     )
   )
   (setq nw_pl
     (vlax-invoke Space 'AddLightWeightPolyline
       (apply 'append (mapcar 'list (mapcar 'car lst_pt) (mapcar 'cadr lst_pt)))
     )
   )
   (vlax-put nw_pl 'Closed 1)
   (vlax-put nw_pl 'Elevation (caddr (trans (trans pt_pos 1 0) 0 1 T)))
   (vlax-put nw_pl 'Layer "Id-XY")
 )
 (prin1)
)

Modifié le 15 septembre 2017 par bonuscad

[lili2006]

Bonsoir à toutes et tous,

 

Salut Bruno,

 

Chez moi =>

 

Commande: (LOAD "C:/Users/lili2006/Desktop/coord-xy_field.LSP") ; erreur: placement incorrect d'un point en entrée

Commande: coord-xy_field

Commande inconnue "COORD-XY_FIELD". Appuyez sur F1 pour obtenir de l'aide.

[bonuscad]

Bonsoir à toutes et tous,

 

Salut Bruno,

 

Chez moi =>

 

Un guillemet qui avait sauté lors du copier-coller, j'ai corrigé...

Recopie à nouveau le code!

[lili2006]

Bonjour à toutes et tous,

 

Salut Bruno,

 

En effet, marche impeccable maintenant !

 

Très pratique lorsque l'on a pas Covadis par exemple,...

 

Je vais faire une version avec les coordonnées exprimées en Est et Nord puisque nous rattachons désormais tous nos travaux,..

 

des coordonnées TOUJOURS depuis le SCG.

 

Super, parce que là aussi, la plupart des étudiants mélangent "vues" et "reperes", c'est gênant pour un topographe,...

 

Merci pour le partage,