Dimensions des boites.

[julbute]

Bonjour à tous,

je reviens sur le sujet...

 

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?

Je ne suis toujours pas un chanpion 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