Aller au contenu
Problème de lien d'inscription (résolu ?) ×

Modification de routine : sélection des entités par rectangle et plus

RémiW

Par RémiW
dans Routines LISP

 Partager

Messages recommandés

RémiW Newbie

RémiW

Posté(e)
Posté(e)

Bonjour à toutes et à tous !

 

Je me permets de solliciter la communauté CADxp afin de modifier une routine existante que j'ai trouvée en me promenant sur Google. (Merci beaucoup Serge Camiré)

 

Le code existant permet de créer un tableau recensant des lignes contenues dans des calques filtrés par préfixes.

Deux colonnes sont créées, une avec le nom du calque et l'autre avec la somme des longueurs de lignes correspondantes.

 

Cette fonction est impeccable pour moi, j'ai déjà entamé la personnalisation du code.

 

Malheureusement, mon piètre niveau en lisp ne me permet pas d'adapter le code afin d'en modifier les caractéristiques suivantes :

 

- J'aimerais pouvoir sélectionner la zone de dessin à prendre en compte avec un rectangle (englobant). Pour le moment la routine analyse tout le dessin et cela n'est pas pratique.

- J'aimerais aussi que les valeurs affichées dans la colonne des longueurs cumulées soient au format "0.00" (je travaille sur un dessin en mm mais je désire des valeurs en m, j'ai déjà ajouté un facteur 0.001 aux valeurs à retourner)

 

Quelqu'un serait-il en mesure de m'aider afin de modifier les points ci-dessus ?

 

Dans tous les cas, merci de m'avoir lu :)

 

 
;;; Dessine un tableau illustrant la liste des calques et les linéaires de modèles filtrés (en ModelSpace)
(vl-load-com)


(defun c:TAB (

/ acadObject column ColWidth endPt filteredLayers filteredObjets i LayerCount LayerName layerNames lcLayerName 

  LineWeightMedium LineWeightNone LineWeightThick ModelSpace n NumColumns NumRows objectName perimeter Point3D_UCS 

  Point3D_WCS Resultat Resultats row RowHeight tableau textsize ThisDrawing Total vlaLayers vlaPoint3D vlaTableau 

  ) 



  ;; ======================================================================================================================

  ;; Personnalisation

  ;; ======================================================================================================================



  ;; Liste des calques et objets désirés, séparés par des virgules, sans espace, wildcard acceptés, en minuscules ou majuscules

  ;; Exemple pour calques: "*" pour tous les calques, "E*,Z*" pour tous ceux qui commencent par E et par Z

  ;; Exemple pour objets "*" pour tous les objets "*line,circle" pour tous les objets dont le nom se termine par "line", ainsi que les cercles

  (setq filteredLayers "_RUPT_*")  

  (setq filteredObjets "*line")  


  ;; Taille du tableau

  (setvar "TEXTSIZE" 300.0) 

  (setq textsize (getvar "textsize"))          ; Voir cette variable qui contrôle la hauteur du texte

  (setq RowHeight (* 2 textsize))

  (setq ColWidth (* 10 RowHeight))		; Largeur totale du tableau = 2 * ColWidth puisqu'on a 2 colonnes Largeur des colonnes

  ;;(setq ColHeight (* 120.0 RowHeight))

  (setq LineWeightThick acLnWt015)             ; Épaisseur de la ligne de séparation (voir LWDISPLAY)

  (setq LineWeightMedium acLnWt015)            ; Épaisseur de la ligne de séparation (voir LWDISPLAY)

  (setq LineWeightNone acLnWt015)              ; Épaisseur de la ligne de séparation (voir LWDISPLAY)




  ;; ======================================================================================================================

  ;; Ne pas modifier la suite du programme

  ;; ======================================================================================================================


  (setq filteredLayers (strcase filteredLayers t))  ; Minuscules

  (setq filteredObjets (strcase filteredObjets t))  ; Minuscules



  (setq acadObject (vlax-get-acad-object))

  (setq ThisDrawing (vla-get-ActiveDocument acadObject))

  (setq ModelSpace (vla-get-ModelSpace ThisDrawing))

  (setq vlaLayers (vla-get-Layers ThisDrawing))

  (setq LayerCount (vla-get-count vlaLayers))


  (setq Point3D_UCS (getpoint "\nPoint d'insertion: "))

  (setq Point3D_WCS (trans Point3D_UCS 1 0))  ; Si pas en WCS

  (setq vlaPoint3D (PointToVariant Point3D_WCS))


  ;; En AutoLISP, il n'y a pas de tableau. On va se créer un faux tableau avec des clés (hash table)

  ;; dont les paires sont (LayerName Count)

  (setq Resultats nil)

  (setq layerNames nil)

  (vlax-for vlaLayer vlaLayers

     (setq layerName (vla-get-name vlaLayer))

     (setq lcLayerName (strcase layerName t))  ; Minuscules

     (if (wcmatch lcLayerName filteredLayers) (setq layerNames (cons lcLayerName layerNames)))

  )

  (setq layerNames (vl-sort layerNames '<))  ; Trier en ordre croissant

  (setq Resultats (mapcar '(lambda (x) (cons x 0.0)) layerNames))


  (vlax-for vlaObject ModelSpace



     (if (and (wcmatch (setq objectName (strcase (vla-get-ObjectName vlaObject) t)) filteredObjets)

              (wcmatch (setq layerName (strcase (vla-get-Layer vlaObject) t)) filteredLayers)

         )

     (progn

        (setq endPt (vlax-curve-getEndParam vlaObject))

        (setq perimeter (vlax-curve-getDistAtParam vlaObject endPt))

        (setq Total (+ perimeter (cdr (assoc layerName Resultats))))

        (setq Resultats (subst (cons layerName Total) (assoc layerName Resultats) Resultats)) 

     ))

  )

  (setq NumRows (length layerNames));; Nombre de lignes en fonction du nombre de calques

  (setq NumRows (+ NumRows 2));; Ajout 2 lignes de titre

  ;;(setq NumColumns 2)

  (setq NumColumns 2) ;; Nombre de colonne

  (setq vlaTableau (vla-AddTable ModelSpace vlaPoint3D NumRows NumColumns RowHeight ColWidth))


  ;; Ligne 0

  (setq row 0)

  (setq column 0)

  ;;(SetCellProperties vlaTableau row column "RECAPITULATIF" textsize acMiddleCenter nil)

  (SetCellProperties vlaTableau row column "RECAPITULATIF" textsize acMiddleCenter nil)

  (setvar "textsize" 3) ;; changement ecriture taille du texte dans les cellules

  ;; Ligne 1, colonne 0

  (setq row 1)

  (setq column 0)

  (SetCellProperties vlaTableau row column "Modèle" textsize acMiddleCenter (cons acHorzBottom LineWeightMedium))


  ;; Ligne 1, colonne 1

  (setq row 1)

  (setq column 1)

  (SetCellProperties vlaTableau row column "Linéaires (m)" textsize acMiddleCenter (cons acHorzBottom LineWeightMedium))


  ;; Lignes de résultat

  (setq i 0)

  (setq n (length layerNames)) ;;Ecriture des lignes du filtre

  (setq Total 0.0)

  (while (< i n);remplacer 4 par n

     (setq Resultat (nth i Resultats))

     (setq row (+ i 2))


     ;; Calques

     (setq column 0)

     (setq layerName (strcase (car Resultat)))

     (SetCellProperties vlaTableau row column layerName textsize acMiddleCenter nil)


     ;; Linéaires des modèles

     (setq column 1)

     (setq perimeter (cdr Resultat))

     (setq Total (+ Total perimeter))

     (SetCellProperties vlaTableau row column (rtos (* perimeter 0.001)) textsize acMiddleCenter nil)

     (setq i (1+ i))

  ) 

)



(defun SetCellProperties (

  vlaTableau Row Column Texte TextHeight Alignment LineWeightPair

  )

  ;; Gère les propriétés populaires des cellules d'un tableau

  ;;    vlaTableau Row Column : Obligatoire, les autres sont facultatifs

  ;;    Row, Column : INT, base 0

  ;;    Alignment: INT, 

  ;;    LineWeightPair: nil, sinon (cons "AcGridLineType enum" "acad_lweight enum"), soit (cons Position Épaisseur)

  ;; Support pour Acad2006 et Acad2009

  (if LineWeightPair (vla-SetCellGridLineWeight vlaTableau Row Column (car LineWeightPair) (cdr LineWeightPair)))

  (if Alignment (vla-SetCellAlignment vlaTableau Row Column Alignment))

  (if TextHeight (vla-SetCellTextHeight vlaTableau Row Column TextHeight))

  (if Texte

     (if vla-SetCellValue 

        (vla-SetCellValue vlaTableau Row Column Texte) ; AutoCAD 2009

        (vla-SetText vlaTableau Row Column Texte)      ; AutoCAD 2006

     )

  )

)


;;; PointToVariant

;;; Conversion de Point2D ou Point3D en variant

(defun PointToVariant (

  point

/ arraySpace sArray

  )

  (setq arraySpace (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length point)))))

  (setq sArray (vlax-safearray-fill arraySpace point))

  (vlax-make-variant sArray)

)

Lien vers le commentaire
Partager sur d’autres sites
Tramber Apprentice

Tramber

Posté(e)
Posté(e)

Remplace l'expression complète (vlax-for vlaObject ModelSpace .... )

Par :

(if (ssget)
 (progn
   (vlax-for vlaObject (setq sel (vla-get-ActiveSelectionSet(vla-get-ActiveDocument(vlax-get-acad-object))))
     
     (if (and (wcmatch (setq objectName (strcase (vla-get-ObjectName vlaObject) t)) filteredObjets)

              (wcmatch (setq layerName (strcase (vla-get-Layer vlaObject) t)) filteredLayers)

         )

     (progn

        (setq endPt (vlax-curve-getEndParam vlaObject))

        (setq perimeter (vlax-curve-getDistAtParam vlaObject endPt))

        (setq Total (+ perimeter (cdr (assoc layerName Resultats))))

        (setq Resultats (subst (cons layerName Total) (assoc layerName Resultats) Resultats)) 

     ))
   )
   (vla-delete sel)
 ) 
)

 

Cela devrait marcher.

 

A la fin, tu peux jouer avec FIX :

 

(*(fix(* perimeter 0.1))0.01)

Bureau d'études dessin.

Spécialiste Escaliers

Développement - Formation

 

./__\.
(.°=°.)
Lien vers le commentaire
Partager sur d’autres sites
RémiW Newbie

RémiW

Posté(e)
  • Auteur
Posté(e)

Salut Tramber,

 

Merci pour ta réponse super rapide !

L'arrondi des valeurs au format "0.00" dans le tableau marche super, je te remercie !

 

Pour ce qui est de la sélection par rectangle, il y a du mieux mais j'ai sûrement omis des détails importants dans mon explication.

 

La colonne des linéaires est désormais effectivement complétée avec uniquement les linéaires inclus dans le rectangle de sélection.

Cependant, la colonne des noms de calques me retourne quand même l'ensemble des calques ayant le préfixe "_RUPT_*" des lignes contenues dans l'espace objet.

Mon idée était que seuls les calques de préfixe "_RUPT_*" des lignes contenues dans le rectangle de sélection devaient s'afficher dans la première colonne.

 

J'espère que mon analyse est claire ^^ En tout cas c'est super sympa de prendre de ton temps pour ma question :)

Lien vers le commentaire
Partager sur d’autres sites
RémiW Newbie

RémiW

Posté(e)
  • Auteur
Posté(e)

Après intégration de tes suggestions, le code ressemble à ça :

 

;;; Dessine un tableau illustrant la liste des calques et les linéaires de modèles filtrés (en ModelSpace)
(vl-load-com)


(defun c:TAB (

/ acadObject column ColWidth endPt filteredLayers filteredObjets i LayerCount LayerName layerNames lcLayerName 

  LineWeightMedium LineWeightNone LineWeightThick ModelSpace n NumColumns NumRows objectName perimeter Point3D_UCS 

  Point3D_WCS Resultat Resultats row RowHeight tableau textsize ThisDrawing Total vlaLayers vlaPoint3D vlaTableau 

  ) 



  ;; ======================================================================================================================

  ;; Personnalisation

  ;; ======================================================================================================================



  ;; Liste des calques et objets désirés, séparés par des virgules, sans espace, wildcard acceptés, en minuscules ou majuscules

  ;; Exemple pour calques: "*" pour tous les calques, "E*,Z*" pour tous ceux qui commencent par E et par Z

  ;; Exemple pour objets "*" pour tous les objets "*line,circle" pour tous les objets dont le nom se termine par "line", ainsi que les cercles

  (setq filteredLayers "_RUPT_*")  

  (setq filteredObjets "*line")  


  ;; Taille du tableau

  (setvar "TEXTSIZE" 300.0) 

  (setq textsize (getvar "textsize"))          ; Voir cette variable qui contrôle la hauteur du texte

  (setq RowHeight (* 2 textsize))

  (setq ColWidth (* 10 RowHeight))             ; Largeur totale du tableau = 2 * ColWidth puisqu'on a 2 colonnes Largeur des colonnes

  ;;(setq ColHeight (* 120.0 RowHeight))

  (setq LineWeightThick acLnWt015)             ; Épaisseur de la ligne de séparation (voir LWDISPLAY)

  (setq LineWeightMedium acLnWt015)            ; Épaisseur de la ligne de séparation (voir LWDISPLAY)

  (setq LineWeightNone acLnWt015)              ; Épaisseur de la ligne de séparation (voir LWDISPLAY)




  ;; ======================================================================================================================

  ;; Ne pas modifier la suite du programme

  ;; ======================================================================================================================


  (setq filteredLayers (strcase filteredLayers t))  ; Minuscules

  (setq filteredObjets (strcase filteredObjets t))  ; Minuscules



  (setq acadObject (vlax-get-acad-object))

  (setq ThisDrawing (vla-get-ActiveDocument acadObject))

  (setq ModelSpace (vla-get-ModelSpace ThisDrawing))

  (setq vlaLayers (vla-get-Layers ThisDrawing))

  (setq LayerCount (vla-get-count vlaLayers))


  (setq Point3D_UCS (getpoint "\nPoint d'insertion: "))

  (setq Point3D_WCS (trans Point3D_UCS 1 0))  ; Si pas en WCS

  (setq vlaPoint3D (PointToVariant Point3D_WCS))


  ;; En AutoLISP, il n'y a pas de tableau. On va se créer un faux tableau avec des clés (hash table)

  ;; dont les paires sont (LayerName Count)

  (setq Resultats nil)

  (setq layerNames nil)

  (vlax-for vlaLayer vlaLayers

     (setq layerName (vla-get-name vlaLayer))

     (setq lcLayerName (strcase layerName t))  ; Minuscules

     (if (wcmatch lcLayerName filteredLayers) (setq layerNames (cons lcLayerName layerNames)))

  )

  (setq layerNames (vl-sort layerNames '<))  ; Trier en ordre croissant

  (setq Resultats (mapcar '(lambda (x) (cons x 0.0)) layerNames))


  (if (ssget)
 (progn
   (vlax-for vlaObject (setq sel (vla-get-ActiveSelectionSet(vla-get-ActiveDocument(vlax-get-acad-object))))
     
     (if (and (wcmatch (setq objectName (strcase (vla-get-ObjectName vlaObject) t)) filteredObjets)

              (wcmatch (setq layerName (strcase (vla-get-Layer vlaObject) t)) filteredLayers)

         )

     (progn

        (setq endPt (vlax-curve-getEndParam vlaObject))

        (setq perimeter (vlax-curve-getDistAtParam vlaObject endPt))

        (setq Total (+ perimeter (cdr (assoc layerName Resultats))))

        (setq Resultats (subst (cons layerName Total) (assoc layerName Resultats) Resultats)) 

     ))
   )
   (vla-delete sel)
 ) 
)

  (setq NumRows (length layerNames));; Nombre de lignes en fonction du nombre de calques

  (setq NumRows (+ NumRows 2));; Ajout 2 lignes de titre

  ;;(setq NumColumns 2)

  (setq NumColumns 2) ;; Nombre de colonne

  (setq vlaTableau (vla-AddTable ModelSpace vlaPoint3D NumRows NumColumns RowHeight ColWidth))


  ;; Ligne 0

  (setq row 0)

  (setq column 0)

  ;;(SetCellProperties vlaTableau row column "RECAPITULATIF" textsize acMiddleCenter nil)

  (SetCellProperties vlaTableau row column "RECAPITULATIF" textsize acMiddleCenter nil)

  (setvar "textsize" 3) ;; changement ecriture taille du texte dans les cellules

  ;; Ligne 1, colonne 0

  (setq row 1)

  (setq column 0)

  (SetCellProperties vlaTableau row column "Modèle" textsize acMiddleCenter (cons acHorzBottom LineWeightMedium))


  ;; Ligne 1, colonne 1

  (setq row 1)

  (setq column 1)

  (SetCellProperties vlaTableau row column "Linéaires (m)" textsize acMiddleCenter (cons acHorzBottom LineWeightMedium))


  ;; Lignes de résultat

  (setq i 0)

  (setq n (length layerNames)) ;;Ecriture des lignes du filtre

  (setq Total 0.0)

  (while (< i n);remplacer 4 par n

     (setq Resultat (nth i Resultats))

     (setq row (+ i 2))


     ;; Calques

     (setq column 0)

     (setq layerName (strcase (car Resultat)))

     (SetCellProperties vlaTableau row column layerName textsize acMiddleCenter nil)


     ;; Linéaires des modèles

     (setq column 1)

     (setq perimeter (cdr Resultat))

     (setq Total (+ Total perimeter))

     (SetCellProperties vlaTableau row column (rtos (*(fix(* perimeter 0.1))0.01)) textsize acMiddleCenter nil)

     (setq i (1+ i))

  ) 

)



(defun SetCellProperties (

  vlaTableau Row Column Texte TextHeight Alignment LineWeightPair

  )

  ;; Gère les propriétés populaires des cellules d'un tableau

  ;;    vlaTableau Row Column : Obligatoire, les autres sont facultatifs

  ;;    Row, Column : INT, base 0

  ;;    Alignment: INT, 

  ;;    LineWeightPair: nil, sinon (cons "AcGridLineType enum" "acad_lweight enum"), soit (cons Position Épaisseur)

  ;; Support pour Acad2006 et Acad2009

  (if LineWeightPair (vla-SetCellGridLineWeight vlaTableau Row Column (car LineWeightPair) (cdr LineWeightPair)))

  (if Alignment (vla-SetCellAlignment vlaTableau Row Column Alignment))

  (if TextHeight (vla-SetCellTextHeight vlaTableau Row Column TextHeight))

  (if Texte

     (if vla-SetCellValue 

        (vla-SetCellValue vlaTableau Row Column Texte) ; AutoCAD 2009

        (vla-SetText vlaTableau Row Column Texte)      ; AutoCAD 2006

     )

  )

)


;;; PointToVariant

;;; Conversion de Point2D ou Point3D en variant

(defun PointToVariant (

  point

/ arraySpace sArray

  )

  (setq arraySpace (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length point)))))

  (setq sArray (vlax-safearray-fill arraySpace point))

  (vlax-make-variant sArray)

)

Lien vers le commentaire
Partager sur d’autres sites
Tramber Apprentice

Tramber

Posté(e)
Posté(e)

J'ai compris (car j'ai regardé très vite ces filtres) mais hélas je dois abandonner pour ce soir.

Sauf si je reviens... :rolleyes:

Sinon à demain !

Lingolsheim. Si ca tombe, t'as juste un prendre un bus ou ton vélo pour me voir ;)

Bureau d'études dessin.

Spécialiste Escaliers

Développement - Formation

 

./__\.
(.°=°.)
Lien vers le commentaire
Partager sur d’autres sites
RémiW Newbie

RémiW

Posté(e)
  • Auteur
Posté(e)

Ah c'est nickel si j'ai été assez clair !

 

Et bien si tu ne reviens plus ce soir, passe une bonne soirée :)

 

Effectivement, le monde du lisp est tout petit apparemment ! Ou alors ce sont les sticks et la Météor qui poussent particulièrement à la programmation ^^

Lien vers le commentaire
Partager sur d’autres sites
Olivier Eckmann Proficient

Olivier Eckmann

Posté(e)
Posté(e)

Bonsoir,

 

juste avant la ligne

 

 (setq NumRows (length layerNames));; Nombre de lignes en fonction du nombre de calques

 

 

tu ajoutes ça

 

  (setq layernames nil Result nil)
  (foreach oTab Resultats
	(if (> (cdr oTab) 0)
  	(progn
  	(setq layernames (append layerNames (list (car oTab))))
  	(setq Result (append Result (list oTab)))
  	)
	)
  )
  (setq Resultats Result)

 

Olivier

Lien vers le commentaire
Partager sur d’autres sites
RémiW Newbie

RémiW

Posté(e)
  • Auteur
Posté(e)

Je vais me permettre d'abuser encore un petit peu de vos connaissances... ^^

 

Est-ce possible de mettre en place une mise en forme du fond de cellule du tableau en fonction de son contenu ?

Je m'explique :

 

Le but serait de colorer le fond de chaque cellule de la première colonne en fonction de son contenu (nom du calque) :

 

Si le nom du calque contient "*Type1*", alors colorer le fond de cellule en Jaune

Si le nom du calque contient "*Type2*", alors colorer le fond de cellule en Bleu

Si le nom du calque contient "*Type3*", alors colorer le fond de cellule en Vert

 

J'ai trouvé sur Google la fonction "vla-setcellcontentcolor" mais je dois avouer m'être perdu dans son utilisation...

 

La dernière version de mon code ressemble à ça :

 

;;; Dessine un tableau illustrant la liste des calques et les linéaires de modèles filtrés (en ModelSpace)
(vl-load-com)


(defun c:TAB (

/ acadObject column ColWidth endPt filteredLayers filteredObjets i LayerCount LayerName layerNames lcLayerName 

  LineWeightMedium LineWeightNone LineWeightThick ModelSpace n NumColumns NumRows objectName perimeter Point3D_UCS 

  Point3D_WCS Resultat Resultats row RowHeight tableau textsize ThisDrawing Total vlaLayers vlaPoint3D vlaTableau 

  ) 



  ;; ======================================================================================================================

  ;; Personnalisation

  ;; ======================================================================================================================



  ;; Liste des calques et objets désirés, séparés par des virgules, sans espace, wildcard acceptés, en minuscules ou majuscules

  ;; Exemple pour calques: "*" pour tous les calques, "E*,Z*" pour tous ceux qui commencent par E et par Z

  ;; Exemple pour objets "*" pour tous les objets "*line,circle" pour tous les objets dont le nom se termine par "line", ainsi que les cercles

  (setq filteredLayers "_RUPT_*")  

  (setq filteredObjets "*line")  

(command "-calque" "ch" "PRESENTATIONS" "")

  ;; Taille du tableau

  (setvar "TEXTSIZE" 300.0) 

  (setq textsize (getvar "textsize"))          ; Voir cette variable qui contrôle la hauteur du texte

  (setq RowHeight (* 2 textsize))

  (setq ColWidth (* 10 RowHeight))             ; Largeur totale du tableau = 2 * ColWidth puisqu'on a 2 colonnes Largeur des colonnes

  ;;(setq ColHeight (* 120.0 RowHeight))

  (setq LineWeightThick acLnWt015)             ; Épaisseur de la ligne de séparation (voir LWDISPLAY)

  (setq LineWeightMedium acLnWt015)            ; Épaisseur de la ligne de séparation (voir LWDISPLAY)

  (setq LineWeightNone acLnWt015)              ; Épaisseur de la ligne de séparation (voir LWDISPLAY)




  ;; ======================================================================================================================

  ;; Ne pas modifier la suite du programme

  ;; ======================================================================================================================


  (setq filteredLayers (strcase filteredLayers t))  ; Minuscules

  (setq filteredObjets (strcase filteredObjets t))  ; Minuscules



  (setq acadObject (vlax-get-acad-object))

  (setq ThisDrawing (vla-get-ActiveDocument acadObject))

  (setq ModelSpace (vla-get-ModelSpace ThisDrawing))

  (setq vlaLayers (vla-get-Layers ThisDrawing))

  (setq LayerCount (vla-get-count vlaLayers))


  (setq Point3D_UCS (getpoint "\nPoint d'insertion: "))

  (setq Point3D_WCS (trans Point3D_UCS 1 0))  ; Si pas en WCS

  (setq vlaPoint3D (PointToVariant Point3D_WCS))


  ;; En AutoLISP, il n'y a pas de tableau. On va se créer un faux tableau avec des clés (hash table)

  ;; dont les paires sont (LayerName Count)

  (setq Resultats nil)

  (setq layerNames nil)

  (vlax-for vlaLayer vlaLayers

     (setq layerName (vla-get-name vlaLayer))

     (setq lcLayerName (strcase layerName t))  ; Minuscules

     (if (wcmatch lcLayerName filteredLayers) (setq layerNames (cons lcLayerName layerNames)))

  )

  (setq layerNames (vl-sort layerNames '<))  ; Trier en ordre croissant

  (setq Resultats (mapcar '(lambda (x) (cons x 0.0)) layerNames))


  (if (ssget)
 (progn
   (vlax-for vlaObject (setq sel (vla-get-ActiveSelectionSet(vla-get-ActiveDocument(vlax-get-acad-object))))
     
     (if (and (wcmatch (setq objectName (strcase (vla-get-ObjectName vlaObject) t)) filteredObjets)

              (wcmatch (setq layerName (strcase (vla-get-Layer vlaObject) t)) filteredLayers)

         )

     (progn

        (setq endPt (vlax-curve-getEndParam vlaObject))

        (setq perimeter (vlax-curve-getDistAtParam vlaObject endPt))

        (setq Total (+ perimeter (cdr (assoc layerName Resultats))))

        (setq Resultats (subst (cons layerName Total) (assoc layerName Resultats) Resultats)) 

     ))
   )
   (vla-delete sel)
 ) 
)

  (setq layernames nil Result nil)
  (foreach oTab Resultats
       (if (> (cdr oTab) 0)
       (progn
       (setq layernames (append layerNames (list (car oTab))))
       (setq Result (append Result (list oTab)))
       )
       )
  )
  (setq Resultats Result)

  (setq NumRows (length layerNames));; Nombre de lignes en fonction du nombre de calques

  (setq NumRows (+ NumRows 2));; Ajout 2 lignes de titre

  ;;(setq NumColumns 2)

  (setq NumColumns 2) ;; Nombre de colonne

  (setq vlaTableau (vla-AddTable ModelSpace vlaPoint3D NumRows NumColumns RowHeight ColWidth))


  ;; Ligne 0

  (setq row 0)

  (setq column 0)

  ;;(SetCellProperties vlaTableau row column "RECAPITULATIF" textsize acMiddleCenter nil)

  (SetCellProperties vlaTableau row column "RECAPITULATIF" textsize acMiddleCenter nil)

  (setvar "textsize" 3) ;; changement ecriture taille du texte dans les cellules

  ;; Ligne 1, colonne 0

  (setq row 1)

  (setq column 0)

  (SetCellProperties vlaTableau row column "Modèle" textsize acMiddleCenter (cons acHorzBottom LineWeightMedium))


  ;; Ligne 1, colonne 1

  (setq row 1)

  (setq column 1)

  (SetCellProperties vlaTableau row column "Linéaires (m)" textsize acMiddleCenter (cons acHorzBottom LineWeightMedium))


  ;; Lignes de résultat

  (setq i 0)

  (setq n (length layerNames)) ;;Ecriture des lignes du filtre

  (setq Total 0.0)

  (while (< i n);remplacer 4 par n

     (setq Resultat (nth i Resultats))

     (setq row (+ i 2))


     ;; Calques

     (setq column 0)

     (setq layerName (strcase (car Resultat)))

     (SetCellProperties vlaTableau row column layerName textsize acMiddleCenter nil)


     ;; Linéaires des modèles

     (setq column 1)

     (setq perimeter (cdr Resultat))

     (setq Total (+ Total perimeter))

     (SetCellProperties vlaTableau row column (rtos (*(fix(* perimeter 0.1))0.01)) textsize acMiddleCenter nil)

     (setq i (1+ i))

  ) 

)



(defun SetCellProperties (

  vlaTableau Row Column Texte TextHeight Alignment LineWeightPair

  )

  ;; Gère les propriétés populaires des cellules d'un tableau

  ;;    vlaTableau Row Column : Obligatoire, les autres sont facultatifs

  ;;    Row, Column : INT, base 0

  ;;    Alignment: INT, 

  ;;    LineWeightPair: nil, sinon (cons "AcGridLineType enum" "acad_lweight enum"), soit (cons Position Épaisseur)

  ;; Support pour Acad2006 et Acad2009

  (if LineWeightPair (vla-SetCellGridLineWeight vlaTableau Row Column (car LineWeightPair) (cdr LineWeightPair)))

  (if Alignment (vla-SetCellAlignment vlaTableau Row Column Alignment))

  (if TextHeight (vla-SetCellTextHeight vlaTableau Row Column TextHeight))

  (if Texte

     (if vla-SetCellValue 

        (vla-SetCellValue vlaTableau Row Column Texte) ; AutoCAD 2009

        (vla-SetText vlaTableau Row Column Texte)      ; AutoCAD 2006

     )

  )

)


;;; PointToVariant

;;; Conversion de Point2D ou Point3D en variant

(defun PointToVariant (

  point

/ arraySpace sArray

  )

  (setq arraySpace (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length point)))))

  (setq sArray (vlax-safearray-fill arraySpace point))

  (vlax-make-variant sArray)

)

 

Un grand merci :)

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
 Partager
Aller sur la liste des sujets
×
×
  • 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é