;| fep fil d'eau suivant pente
le bloc re_fe doit etre présent ) charger ici :
joch04.free.fr/images/lisp_ini/poly1.dwg


  Un grand merci à Patrick_35 pour ces explication sur l'utilisation du Vlisp nécéssaire pour
  attaquer les blocs dynamiques voir ici; 
  http://cadxp.com/topic/41522_modifier_un_attribut_de_bloc_dynamique/page__view__findpost__p__233995
  

|;

(defun c:tmp (/	choix 		unit		ech		ang		Nr
        ent 		Fe		lay		lay0		pe              bloc
	poly		lst_pts		ord		pt		pt0     lstdxf
	ptbl		lst_b		lst_bloc	lst_tmp 	flag	     )

  (vl-load-com)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark doc)
  
  ;;initialisation des variables globales si elle ne sont pas afféctées
  (if (/= (type *unit*) 'REAL)
    (setq *unit* 1.0 )
  )
    (if (/= (type *scale*) 'REAL)
    (setq *scale* 1.0)
  )
  (if (/= (type *angle*) 'REAL)
    (setq *angle* 0.0)
  )
  (if (/= (type *val_R*) 'INT)
    (setq *val_R* 0)
  )
  (if (/= (type *val_fe*) 'REAL)
    (setq *val_fe* 0.0)
  )
  (if (/= (type *pente*) 'REAL)
    (setq *pente* 0.01)
  )
  (if (/= (type *claque*) 'STR)
    (setq *claque* "-see-cotes-fe")
  )

  ;;messages d'introduction
  (print
    "Cotation des sommets d'une polyligne et fonction de la pente (le bloc re_fe doit etre présent dans le dessin)"
  )

  ;; on initialise ici des variables locales pour éviter les effets de bords

  (setq unit *unit*
	ech *scale*
	ang *angle*
	Nr *val_R*
	Fe *val_fe*
	lay *claque*
	pe *pente*)

  
  ;;boucle select un pts ou modif paramètres
  (while
    (and
      (princ
	(strcat
	  "\nLes paramètres actuels sont:"
	  "\nEchelle (1 pour lisibilité au 1/100°)= "
	  (rtos *scale*)
	  "  Angle (deg décimaux)= "
	  (rtos (* *angle* (/ 180 pi)))
	  "  N° 1er regard: "
	  (itoa (1+ *val_R*))
	  "  Fe départ: "
	  (rtos *val_fe*)
	  "\n  Calque: "
	  *claque*
	  "  Pente: "
	  (rtos *pente*)
	  "\nSélectionnez le point de départ ou espace pour changer un paramètre"
	)
      ) ;_ Fin de print
      (not (setq pt (getpoint)))
    ) ;_ Fin de and

     (initget 1 "Echelle Angle Num-regard Fe Calque Pente")
     (setq choix
	    (getkword
	      "\nChoix de l'option [Echelle Angle Num-regard Fe Calque Pente]: "
	    )
     )
     (cond
       ((= choix "Echelle")
	(if (setq ech
		   (getreal
		     (strcat
		       "\nEchelle du bloc ? (1 pour 1/100, 0.5 pour 1/200, ext...) <"
		       (rtos *scale*)
		       "> :"
		     )
		   )
	    )
	  (setq *scale* ech)
	  (setq ech *scale*)

	)
       )
       ((= choix "Angle")
	(if (setq ang (getreal (strcat "\nAngle en degré ? <"
				       (rtos (* *angle* (/ 180 pi)))
				       "> "
			       )
		      )
	    )
	  (setq *angle* (* ang (/ pi 180)))
	  (setq ang (* *angle* (/ 180 pi)))
	)
       )
       ((= choix "Num-regard")
	(if (setq Nr
		   (getint
		     (strcat "\nN° du 1er regard ? <" (itoa *val_R*) "> :")
		   )
	    )
	  (setq *val_R* Nr)
	  (setq Nr *val_R*)
	)

       )
       ((= choix "Fe")
	(if (setq Fe (getreal (strcat "\nFil d'eau de départ ? <"
				     (rtos *val_fe*)
				     "> :"
			     )
		     )
	    )
	  (setq *val_fe* Fe)
	  (setq Fe *val_fe*)

	)
       )
       ((= choix "Calque")
	(if
	  (setq
	    lay	(getstring (strcat
			     "\nCalque dans le quel seront poser les regard ? <"
			     *calque*
			     ">"
			   )
		)
	  )
	   (setq *calque* lay)
	   (setq lay *calque*)
	)
       )
       ((= choix "Pente")
	(if (setq
	      pe (getreal
		   (strcat
		     "\nPente ? (0.01 pour 1% descente si négatif) <"
		     (rtos *pente*)
		     "> :"
		   )
		 )
	    )
	  (setq *pente* pe)
	  (setq pe *pente*)
	)
       )
     ) ;_ Fin de cond
  ) ;_ Fin de while             les paramètres sont initialisés et on a un point
  
    ;;   transformer le point 3d de getpoint en point 2d du scg
  (setq	pt (trans pt 1 0)
	pt (list (car pt) (cadr pt))
  )							    

  ;;sélection et extraction de la liste de point de la polyligne                          
  ;; voir ici cadxp.com/topic/4132_sommets_dune_lwpolyligne/page__view__findpost__p__18891
  (princ "\n Sélectionnez la polyligne à coter")
  (setq poly (ssname (ssget '((0 . "LWPOLYLINE"))) 0))
  (setq	lst_pts	(mapcar	'cdr
			(vl-remove-if-not
			  '(lambda (x) (= (car x) 10))
			  (entget poly)
			)
		)
  )
  ;; si le point est à une des 2 extrémités on teste l'ordre dans la liste
  ;; sinon, on signale qu'on ne continu pas                               
  (setq ord 2)
  (if (equal pt (car lst_pts) 0.0005)
    (setq ord 0)
  )
  (if (equal pt (last lst_pts) 0.0005)
    (setq ord 1)
  )
  (if (= ord 1)
    (setq lst_pts (reverse lst_pts))
  )
  (if (= ord 2)
    (progn
      (princ
	"\n Le point n'est pas sur une extrémité sortie du programme"
      )
      (exit)
    )
  )
  ;; recherche des blocs présents sur la liste des points 
  (setq	i 0
	lst_bloc nil
	lst_tmp nil
  )
;; lst_b est une liste des blocs du dessin   
(setq lst_b (ssget "_X"  '((0 . "INSERT")) ))
  
 ;; dans cette boucle, on va créer une liste de travail avec les listes dxf + le effectivename
 ;; Qu'on va trier pour ne garder que le point d'insertion et le handle si ce sont des re-fe  
  (repeat (sslength lst_b)
    (setq ent (ssname lst_b i))				    ; ent est l'entité placée en position i du selection-set ss
    (setq lstdxf (fdxf ent))				    ; je stoke dans lstdxf la valeur de retour de la fonction fdxf pour l'élément ent
    ;; le bolc est il un ref-scu   
    (if	(= (cdr (car lstdxf)) "re-fe")			    ; test si le bloc est un re-fe
      (setq lst_tmp (cons lstdxf lst_tmp))		    ;Si oui on le stoke dans la liste de travail
    );;  fin du if 
    (setq i (1+ i))					    ; incrément pour parcours de lstdxf
  );; fin repeat on a une liste dxf "étendue" des bloc re-fe du dessin

  (setq lst_b lst_tmp)

  ;; on trie cette liste si leur pts d'insertion n'est pas sur la polyligne
    (repeat (length lst_b)
    (setq pt_b    (cdr (assoc 10  (car lst_tmp) )) )
    (setq pt_b	  (list (car pt_b) (cadr pt_b)) 
	  hd_b	  (cdr  (assoc 5  (car lst_tmp) ))
	  lst_tmp2 lst_pts	  
    )
    (repeat (length lst_pts)
      (if (equal pt_b (car lst_tmp2) 0.0005)
	(setq lst_bloc (cons (list pt_b hd_b) lst_bloc))
      )
     (setq lst_tmp2 (cdr lst_tmp2)) 
    )						  ;fin repeat pts
    (setq lst_tmp (cdr lst_tmp))
  );; fin repeat bloc       
;;;   la worklist est prète 

  
  ;; création du calque de cotation s'il nexiste pas
  (if (not (tblsearch "LAYER" lay))
    (entmakex (list '(0 . "LAYER")
		    '(100 . "AcDbSymbolTableRecord")
		    '(100 . "AcDbLayerTableRecord")
		    (cons 2 lay)
		    '(70 . 0)  ; claque non gelé
		    '(62 . 83) ; couleur        
	      )
    )
  )
  (setvar "clayer" lay) ; passer lay en calque courant  

;; initialisation pour la boucle  
  
    (setq i	  0
	  lst_tmp lst_pts
	  pt0	  pt
	  nr	  (1- nr)				    ;on décrémente nr pour l'incrémenté dans la boucle sinon on partirait de N+1
	  lay0	  (getvar "clayer")			    ; on stoque la valeur du calque courant
    )

;;   boucle de création / mise à jour des blocs
  
  (repeat (length lst_pts)
    (setq pt   (car lst_tmp)
	  fe   (+ fe (* pe (distance pt pt0)))
	  nr   (1+ nr)
	  flag 0
    )
    (foreach bloc lst_bloc
      (if (equal pt (car bloc) 0.0005)			    ; si le bloc existe pour ce point
	(progn
	  (Vb-Mod-att (handent (cadr bloc)) "R" (itoa nr) );; Vb_Mod_att (ent nomatt Nval
	  (Vb-Mod-att (handent (cadr bloc)) "FE" (rtos fe 2 2))
	  (setq flag 1)					    ;on note ici que le bloc existe pour ce point
	)
      )
    )
    (if	(= flag 0)					    ; si aucun bloc n'a été mis à jour ul faut en créer un
      (command "_.-insert" "re-fe" "_non" (trans pt 0 1) ech ech ang (itoa nr) (rtos fe 2 2))
    )
    (setq lst_tmp (cdr lst_tmp))
  )							    ;fin repeat pts

  (setvar "clayer" lay0)
  (setq	*val_R*	Nr
	*val_fe* Fe
  )
  (princ)

  (vla-endundomark doc)				  ; Fin de l'undo
  (princ)

)						  ;fin defun


;;                                                                                   
;;        les fonctions utilisées                                                    
;;                                                                                   


;; Vb-Mod-att fonction Vlisp pour modifier la valeur d'un attribut
(defun Vb-Mod-att (ent nomatt Nval / att i )
  (setq i 0 )
  (foreach att
	   (vlax-invoke (vlax-ename->vla-object ent) 'getattributes)
    (and (eq (vla-get-tagstring att) nomatt)
	 (vla-put-textstring (nth i (vlax-invoke (vlax-ename->vla-object ent) 'getattributes))  nval )
    )
    (setq i (1+ i))
  )
)					; fin Vb-Mod-att 



;;;;                Fdxf avec effective name  VBA                                 


(defun Fdxf (entite / lstdxf)			  ; l'argument et la variable
  (setq lstdxf (entget entite))			  ; liste dxf normale
;;; definition du nom vba de l'entite
  (setq Vba-ent (vlax-ename->vla-object entite))
;;; récupération du effectivename et ajout à la lstdxf
  (setq bdn (vla-get-effectivename Vba-ent))
  (setq lstdxf (cons (cons "EffNameBlDyn" bdn) lstdxf))

  lstdxf					  ; le rappel de la variable sans rien sert
						  ;de valeur de retour de la fonction
)