Probleme sur un lisp recompose

[kaisho]

Bonjour à tous,

 

Je ne suis pas un habitué du lisp mais j'en ai fait il y a bien longtemps. je recupère des bouts de LISP fait par un peu tout le monde que je monte comme je peux pour que cela fonctionne. Mais la je bloque complet... je souhaite récuperer des polylignes avec la longueur et le cumul par calque. le tout à écrire sur EXCEL. Je vous dépose le bout de LISP.... si quelqu'un pouvait me débrouiller la fin du programme qui n'arrive pas à synthétiser le cumul par calque.. De plus je souhaite que le fichier EXCEL s'ouvre à la fin de la commande... Si c'est pas trop demandé.

Merci beaucoup

 

;(defun metres (/ ss tot nb n long obj lst lay l_lay)

 

;(vl-load-com)

 

(if (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))

 

(progn

(setq fn (getfiled "Fichier de métrés" "" "xls" 1))

(setq fh (open fn "w"))

(setq nb (sslength ss)

 

n 0

 

tot 0.0)

 

(write-line

 

(strcat "\n\nLe dessin contient : " (itoa nb) " polylignes (longueurs exprimées en m)")

 

fh)

(repeat nb

 

(setq obj (vlax-ename->vla-object (ssname ss n))

 

long (vlax-curve-getDistAtParam

 

obj

 

(vlax-curve-getEndParam obj)

 

)

 

tot (+ tot long)

 

lay (vla-get-Layer obj)

 

)

(write-line (strcat "\nPolyligne"

 

(itoa (setq n (1+ n)))

 

" = "

 

(rtos long)

 

"\tCalque : "

 

lay

 

)

 

fh)

)

(if (setq l_lay (assoc lay lst))

 

(setq lst (subst (cons lay (+ long (cdr l_lay))) l_lay lst))

 

(setq lst (cons (cons lay long) lst))

 

)

 

)

 

(mapcar '(lambda (x)

 

(write-line (strcat "\nLongueur totale sur le calque "

 

(car x)

 

" : "

 

(rtos (cdr x))

 

fh)

 

)

 

)

 

lst

)

)

[bonuscad]

Bonjour,

 

Aucun mérite, pompé sur un code de Patrick_35, juste réarrangé rapidement...

 

; by patrick_35
; mods by beekeecz and bonuscad
(vl-load-com)
(defun c:metres ( / flag doc xls wks lin nam_lay l_cumul sel ent)
 (setq
   flag T
   doc (vla-get-activedocument (vlax-get-acad-object))
 )
 (vla-startundomark doc)
 (setq xls (vlax-get-or-create-object "Excel.Application"))
 (or (setq wks (vlax-get xls 'ActiveSheet))
   (vlax-invoke (vlax-get xls 'workbooks) 'Add)
 )
 (setq
   wks (vlax-get xls 'ActiveSheet)
   lin 2
 )
 (vlax-put xls 'Visible :vlax-true)
 (vlax-put (vlax-get-property wks 'range "A1") 'value "Type-Entité")
 (vlax-put (vlax-get-property wks 'range "B1") 'value "Calque")
 (vlax-put (vlax-get-property wks 'range "C1") 'value "Longueur")
 (while (setq def_lay (tblnext "LAYER" flag))
   (setq nam_lay (cdr (assoc 2 def_lay)) flag nil l_cumul 0.0)
   (and (ssget "_X" (list (cons 0 "LWPOLYLINE") (cons 8 nam_lay)))
     (progn
       (vlax-for ent (setq sel (vla-get-activeselectionset doc))
         (vlax-put (vlax-get-property wks 'range (strcat "A" (itoa lin))) 'value (vlax-get ent 'ObjectName))
         (vlax-put (vlax-get-property wks 'range (strcat "B" (itoa lin))) 'value (vlax-get ent 'Layer))
         (vlax-put (vlax-get-property wks 'range (strcat "C" (itoa lin))) 'value (read (rtos (setq e_length (vlax-get ent 'Length)) 2 2)))
         (setq lin (1+ lin) l_cumul (+ e_length l_cumul))
       )
       (vla-delete sel)
     )
   )
   (vlax-put (vlax-get-property wks 'range (strcat "C" (itoa lin))) 'value (read (rtos l_cumul 2 2)))
   (setq lin (1+ lin))
 )
 (mapcar 'vlax-release-object (list wks xls))
 (gc)(gc)
 (vla-endundomark doc)
 (princ)
)

[(gile)]

Salut,

 

Si tu fais du "patchwork" avec des codes récupérés à droite et à gauche, tu as intérêt à les organiser en routines.

 

;; Retourne un liste de sous-listes des cumuls de longueur de polyligne par calque
;; ((nom_calque nombre_polylignes longueur_cumulée) ...)
(defun LongueurPolyligneParCalque (/ ss i pline layer lst sub)
 (if (setq ss (ssget "_X" '((0 . "LWPOLYLINE") (410 . "Model"))))
   (repeat (setq i (sslength ss))
     (setq pline (ssname ss (setq i (1- i)))
           layer (getpropertyvalue (getpropertyvalue pline "LayerId") "Name")
           leng  (getpropertyvalue pline "Length")
     )
     (setq lst
            (if (setq sub (assoc layer lst))
              (subst (list layer (1+ (cadr sub)) (+ (caddr sub) leng)) sub lst)
              (cons (list layer 1 leng) lst)
            )
     )
   )
 )
)

;; Ecrit les données dans Excel
;;
;; Argument
;; data : une liste contenant un sous liste de données par rangée
(defun EcrireExcel (data / xlApp wBook cells i j)
 (setq xlApp (vlax-create-object "Excel.Application")
       wBook (vlax-invoke-method (vlax-get-property xlapp 'WorkBooks) 'Add)
       cells (vlax-get-property xlApp 'Cells)
       i     0
 )
 (foreach row data
   (setq i (1+ i)
         j 0
   )
   (foreach val row
     (setq j    (1+ j)
           cell (vlax-variant-value (vlax-get-property cells 'Item i j))
     )
     (vlax-put-property cell 'Value2 val)
   )
 )
 (vlax-invoke-method
   (vlax-get-property
     (vlax-get-property xlApp 'ActiveSheet)
     'Columns
   )
   'AutoFit
 )
 (vlax-put-Property xlApp 'Visible :vlax-true)
)

;; Ecrit les longueurs de polyligne par calque
(defun c:metres (/ data filename)
 (and
   (setq data (LongueurPolyligneParCalque))
   (EcrireExcel (cons '("Calque" "Nombre" "Longueur") data))
 )
 (princ)
)

[kaisho]

Bonjour,

 

Merci beaucoup à tout les deux... je n'ai que le choix. Merci encore à vous...quel pied de savoir que lorsque l'on a un soucis, on peut toujours compter sur quelqu'un qui maîtrise le sujet sur le bout des doigts... et réponse vitesse "V" en plus...

Est ce que je peux abuser encore un peu de votre temps?

je récupère des plans topo avec beaucoup de calques et je souhaite filtrer les polylignes de certains calques et les copier sur un nouveau dessin Autocad, qu'il soit ouvert et que l'utilisateur se retrouve sur la nouvelle page ouverte avec les nouvelles polylignes filtrées afin d'en faire les métrés.

Je sais que j'en demande beaucoup mais est ce possible d'avoir un exemple de code que je pourrais adapter à plusieurs entités Autocad (blocs, multilignes, textes...etc)

Si c'est possible bien sur.

Pendant que j'y suis, je demande conseil aux "sages" lispeurs. J'aimerai me recoller au LISP que j'ai abandonné il y a longtemps et je vois que cela à évoluer vitesse "V" aussi. Que me conseilleriez vous, soit comme ouvrage, soit comme site sur lequel je pourrai me remettre aux goûts du jour...

Merci encore pour tout et bon début de journée à tous....en cette belle journée ensoleillée

[kaisho]

RE-bonjour à tous,

 

J'ai trouve en fouillant dans les archives LISP de CADXP(fait par framboisette) et j'ai trouvé un LISP (lisp longueur) qui m'irait bien aussi mais le seul inconvénient c'est que la sélection de calque est unique alors que j'aurai besoin de sélectionner plusieurs calques filtrés.

Est ce que j'abuse si je demande à une âme charitable, de me le retoucher afin qu'il réponde à ce besoin mais aussi que le fichier EXCEL s'ouvre dans la foulée? Le summum de la chose serait de sélectionner un fichier EXCEL créer avant par moi (sorte de gabarit EXCEL avec logo et différentes infos en entête.

 

je vous donne le code au cas ou quelqu'un aurait un peu de temps à consacrer à ma demande.MERCI BEAUCOUP par avance...

Je demande peut etre beaucoup.... merci encore

 

 

 

 

; Calcule la longueur des lignes et lwpolylignes du calque spécifié

 

(defun c:metre (/ clq js cnt tot nb_l nb_pl lo_l lo_pl)

 

(vl-load-com)

 

(if (and (setq clq (getlayer nil))

(ssget "_X" (list '(0 . "LINE,LWPOLYLINE") (cons 8 clq)))

(setq nb_l 0

nb_pl 0

lo_l 0.0

lo_pl 0.0

)

)

(progn

(vlax-for o (vla-get-ActiveSelectionSet

(vla-get-ActiveDocument (vlax-get-acad-object))

)

(if (= (vla-get-ObjectName o) "AcDbLine")

(setq nb_l (1+ nb_l)

lo_l (+ lo_l (vla-get-Length o))

)

(setq nb_pl (1+ nb_pl)

lo_pl (+ lo_pl (vla-get-Length o))

)

)

)

(setq descr (strcat

"\nNom de calque..........\t"

clq

"\nNombre de lignes.......\t"

(itoa nb_l)

"\nLongueur de ligne......\t"

(rtos lo_l)

"\nNombre de polylignes...\t"

(itoa nb_pl)

"\nLongueur de polyligne..\t"

(rtos lo_pl)

"\nLongueur totale........\t"

(rtos (+ lo_l lo_pl))

"\n"

)

)

(textscr)

(princ descr)

(initget "Oui Non")

(if (= (getkword

"\nEnregistrer dans un fichier ? [Oui/Non] < Non >: "

)

"Oui"

)

(progn

(setq

file

(open

(getfiled "Créez ou sélectionnez un fichier" "" "xls" 33)

"a"

)

)

(princ descr file)

(close file)

)

)

(graphscr)

)

)

(princ)

)

 

; GetLayer

; Retourne le nom du calque entré ou choisi par l'utilisateur

; dans une liste déroulante de la boite de dialogue ou en sélectionnant à l'écran

 

; Argument : le titre (string) ou nil (défaut : "Choisir un calque")

 

(defun getlayer (titre / lay lst tmp file what_next dcl_id nom)

(while (setq lay (tblnext "LAYER" (not lay)))

(setq lst (cons (cdr (assoc 2 lay)) lst))

)

(setq lst (acad_strlsort lst)

tmp (vl-filename-mktemp "Tmp.dcl")

file (open tmp "w")

)

(write-line

(strcat

"getlayer:dialog{label="

(cond (titre (vl-prin1-to-string titre))

("\"Choisir un calque\"")

)

";initial_focus=\"tp\";

:boxed_column{:row{

:column{:text{label=\"Sélectionner un objet\";alignment=left;}}

:column{:button{label=\">>\";key=\"obj\";alignment=right;fixed_width=true;}

spacer;}}

:edit_box{key=\"tp\";edit_width=25;allow_accept=true;}

:popup_list{key=\"lay\";edit_width=25;}

spacer;}ok_cancel;}"

)

file

)

(close file)

(setq dcl_id (load_dialog tmp))

(setq what_next 2)

(while (>= what_next 2)

(if (not (new_dialog "getlayer" dcl_id))

(exit)

)

(start_list "lay")

(mapcar 'add_list lst)

(end_list)

(or nom

(setq nom (vlax-ldata-get "getLayer" "n"))

(setq nom (vlax-ldata-put "getLayer" "n" "0"))

)

(if (member nom lst)

(set_tile "lay"

(itoa (- (length lst) (length (member nom lst))))

)

(set_tile "lay" "0")

)

(set_tile "tp" nom)

(action_tile "obj" "(done_dialog 3)")

(action_tile "tp" "(setq nom $value)")

(action_tile

"lay"

(strcat

"(if (or (= $reason 1) (= $reason 4))"

"(progn"

"(setq nom (nth (atoi $value) lst))"

"(set_tile \"tp\" (nth (atoi $value) lst))"

"(mode_tile \"tp\" 2)))"

)

)

(action_tile

"accept"

(strcat

"(if (tblsearch \"LAYER\" nom)"

"(progn (done_dialog 1)"

"(vlax-ldata-put \"getLayer\" \"n\" nom))"

"(progn"

"(alert (strcat \"Le calque \" nom \" est introuvable.\"))"

"(setq nom nil) (set_tile \"tp\" (vlax-ldata-get \"getLayer\" \"n\"))"

"(mode_tile \"tp\" 2)))"

)

)

(setq what_next (start_dialog))

(cond

((= what_next 3)

(if (setq nom (car (entsel)))

(setq nom (cdr (assoc 8 (entget nom))))

(setq nom nil)

)

)

((= what_next 0)

(setq nom nil)

)

)

)

(unload_dialog dcl_id)

(vl-file-delete tmp)

nom

)