Liste de boite...

[julbute]

Bonjour à tous,

je reviens sur le sujet dans cette partie de forum qui me semble le meilleur endroit.

(Vous lirez le même poste dans l'espace autocad 2007)

 

Je me sers du code qui suit, afin de retirer les dimensions des "boites" dans mon dessin 3D.

Cela fonctionne plutot pas mal.

Mais j'aimerai avoir dans ma liste, que les boites qui se trouve sur les calques actifs.

Ceux se trouvant sur les calques gelées ne serait pas extrait.

Est 'il possible d'arrondir les valeurs, également?

Est il possible de trier les dimensions de la plus grande à la plus petite?

Je ne suis toujours pas un champion en VBA.

Quelqu'un peut'il m'aider?

Un grand merci.

 

Voici le code, écris par maxence.

 

Option Explicit

 

Public Sub Debits()

Dim JeuSel As AcadSelectionSet

On Error Resume Next

Set JeuSel = ThisDrawing.SelectionSets("DEBITS")

On Error GoTo 0

If JeuSel Is Nothing Then Set JeuSel = ThisDrawing.SelectionSets.Add("DEBITS")

 

Dim FilterType(3) As Integer

Dim FilterData(3) As Variant

 

FilterType(0) = -4

FilterData(0) = " FilterType(1) = 0

FilterData(1) = "3DSOLID"

FilterType(2) = 0

FilterData(2) = "INSERT"

FilterType(3) = -4

FilterData(3) = "OR>"

 

JeuSel.Select acSelectionSetAll, , , FilterType, FilterData

 

If JeuSel.Count = 0 Then

MsgBox "Pas de solides 3D dans le dessin.", vbInformation

Exit Sub

End If

 

Dim NomFichierRapport As String

NomFichierRapport = ThisDrawing.Path & "\" & Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4) & ".txt"

 

On Error GoTo CloseFile

 

Open NomFichierRapport For Output As #1

Print #1, "Nom, X x Y x Z"

 

Dim Entity As AcadEntity

Dim ObjName As String

Dim MinPt, MaxPt

 

For Each Entity In JeuSel

If TypeOf Entity Is AcadBlockReference Then

' C'est un bloc, on utilise son nom

ObjName = Entity.Name

Else

' C'est un solide, on utilise le nom de son calque

ObjName = Entity.Layer

End If

Entity.GetBoundingBox MinPt, MaxPt

Print #1, ObjName & " : " & (MaxPt(0) - MinPt(0)) & " x " & (MaxPt(1) - MinPt(1)) & " x " & (MaxPt(2) - MinPt(2))

Next Entity

 

JeuSel.Delete

 

' Ferme le fichier rapport

Close #1

 

Shell "C:\windows\notepad.exe " & NomFichierRapport, vbNormalFocus

Exit Sub

 

CloseFile:

MsgBox "Une erreur est survenue (" & Err.Description & ")", vbCritical

Close #1

End Sub

[rom1_am]

Bonjour

 

Pour ne prendre en compte que les éléments sur les calques actifs, tu peux rajouter un test avant d'écrire tes valeurs dans le fichier:

 

 If Entity.Layer.Freeze=False Then...

(Il est sûrement possible de rajouter également une condition au moment de la sélection mais je ne sais pas quelle est la syntaxe à utiliser)

 

 

Pour avoir la valeur arrondie, tu peux utiliser la fonction Round(valeur, nombre de décimales):

 Round((MaxPt(0) - MinPt(0)),2)

 

 

Pour trier tes dimensions, le mieux est de reporter toutes tes valeurs dans un tableau ou une collection, de le trier et ensuite d'écrire le contenu du fichier.

 

a+

[julbute]

Bonjour,

Je comprend la commande mais je ne sais pas ou la placer.

Réussir un tableau de donnée n'est pas, encore, ce que je sais faire.

Je pars sur les indications.

Merci pour la réponse,

 

[Edité le 4/11/2009 par julbute]

[julbute]

J'ai essayé de placer la commande, mais cela ne marche pas.

Voici ce que j'ai fait :

 

 Option Explicit

Public Sub Debits()
   Dim JeuSel As AcadSelectionSet
   On Error Resume Next
   Set JeuSel = ThisDrawing.SelectionSets("DEBITS")
   On Error GoTo 0
   If JeuSel Is Nothing Then Set JeuSel = ThisDrawing.SelectionSets.Add("DEBITS")
   
   Dim FilterType(3) As Integer
   Dim FilterData(3) As Variant
   
   FilterType(0) = -4
   FilterData(0) = "    FilterType(1) = 0
   FilterData(1) = "3DSOLID"
   FilterType(2) = 0
   FilterData(2) = "INSERT"
   FilterType(3) = -4
   FilterData(3) = "OR>"

   JeuSel.Select acSelectionSetAll, , , FilterType, FilterData
   
   If JeuSel.Count = 0 Then
       MsgBox "Pas de solides 3D dans le dessin.", vbInformation
       Exit Sub
   End If
   
   Dim NomFichierRapport As String
   NomFichierRapport = ThisDrawing.Path & "\" & Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4) & ".csv"
   
   On Error GoTo CloseFile
   
   Open NomFichierRapport For Output As #1
   Print #1, "Nom, X x Y x Z"
   
   Dim Entity As AcadEntity
   Dim ObjName As String
   Dim MinPt, MaxPt
   
   For Each Entity In JeuSel
       If TypeOf Entity Is AcadBlockReference Then
           ' C'est un bloc, on utilise son nom
           ObjName = Entity.Name
       Else
           ' C'est un solide, on utilise le nom de son calque
           ObjName = Entity.Layer
       End If
       If Entity.Layer.Freeze = False Then
       Entity.GetBoundingBox MinPt, MaxPt
       Print #1, ObjName & " ; " & Round((MaxPt(0) - MinPt(0)), 0) & " ; " & Round((MaxPt(1) - MinPt(1)), 0) & " ;" & Round((MaxPt(2) - MinPt(2)), 0)

       End If
               
       
   Next Entity
   
   JeuSel.Delete
   
   ' Ferme le fichier rapport
   Close #1
   
   Shell "C:\windows\notepad.exe " & NomFichierRapport, vbNormalFocus
   Exit Sub
   
CloseFile:
   MsgBox "Une erreur est survenue (" & Err.Description & ")", vbCritical
   Close #1
End Sub

 

Mais cela ne marche pas.

j'ai un message disant : Erreur de compilation Qualificateur incorrect et il met .freeze en surbrillance.

 

Merci

Rod

[rom1_am]

Je n'avais pas essayé, en effet, on ne peut pas appeler directement "Entity.Layer.Freeze", il faut remplacer l'instruction par :

 

If ThisDrawing.Layers.Item(Entity.Layer).Freeze = False Then...

Ca marche mieux comme ça.