Routine VBA pour extraction d'attribut par nom de bloc

[KSJ77]

Bonjour à tous,

Je cherche à modifier le programme VBA ci dessous afin qu'il n'extrait les attributs que des blocs ayant le nom "Repère".

Pourriez vous m'aider, je ne trouve pas la solution.

Cordialement

 

Public Sub ExtraireAttributs()
 Dim AcadApp As AutoCAD.AcadApplication
 Dim SelSet As AutoCAD.AcadSelectionSet
 Dim FilterType(0) As Integer
 Dim FilterData(0) As Variant
 Dim FiltersType, FiltersData As Variant
 
 Dim i, Row, j, Column As Integer
 Dim Entity As AcadEntity
 Dim BlocRef As AcadBlockReference
 Dim Attributes As Variant
 Dim ColumnExist As Boolean
 
 ' Efface toutes les données contenues dans la feuille
 Range("1:65536").ClearContents
 
 ' On demande le nom du fichier à ouvrir
 Dim Filename As Variant
 Filename = Application.GetOpenFilename("Dessins AutoCAD (*.dwg), *.dwg")
 If Filename = False Then
   Exit Sub
 End If
 Cells(1, 1).Value = Filename
 
 ' Connexion avec AutoCAD (on le lance si il n'est pas en cours d'exécution)
 On Error Resume Next
 Set AcadApp = GetObject(, "AutoCAD.Application")
 On Error GoTo 0
 If AcadApp Is Nothing Then
   Set AcadApp = New AutoCAD.AcadApplication
 End If
 
 ' On ouvre le fichier DWG dans AutoCAD ou on l'active si il est déjà ouvert
 Dim Opened As Boolean
 Opened = False
 
 Dim Dwg As AcadDocument
 For Each Dwg In AcadApp.Documents
   If StrComp(Dwg.FullName, Cells(1, 1).Text, vbTextCompare) = 0 Then
      Dwg.Activate
      Opened = True
   End If
 Next
 
 If Not Opened Then
   AcadApp.Documents.Open (Cells(1, 1).Text)
 End If
 
 ' On remets Excel au premier plan (le lancement d'AutoCAD désactive la fenêtre Excel)
 Application.Visible = True
 
 ' Remplissage de l'entête du tableau
 Cells(3, 1).Value = "Nom du bloc"
 Cells(3, 2).Value = "Handle"
 
 Row = 4 ' 1ère ligne du tableau
 
 ' On crée un jeu de sélection ou on le récupère si il existe déjà
 On Error Resume Next
 Set SelSet = AcadApp.ActiveDocument.SelectionSets.Add("SELSET")
 If Err <> 0 Then
   Set SelSet = AcadApp.ActiveDocument.SelectionSets.Item("SELSET")
   SelSet.Clear
 End If
 
 ' On prépare un filtre de sélection sur les insertions de bloc
 FilterType(0) = 0
 FilterData(0) = "INSERT"
 FiltersType = FilterType
 FiltersData = FilterData
 
 ' Sélection des entités
 SelSet.Select acSelectionSetAll, , , FiltersType, FiltersData
 
 ' On balaye le jeu de sélection
 For i = 0 To SelSet.Count - 1
   Set Entity = SelSet.Item(i)
   
   ' Si l'objet est une insertion de bloc
   If Entity.ObjectName = "AcDbBlockReference" Then
     ' On précise le type de l'objet pour pouvoir accéder à ses propriétés et
     ' ses méthodes spécifiques
     Set BlocRef = Entity
     
     ' Si il a des attributs
     If BlocRef.HasAttributes Then
       Cells(Row, 1).Value = BlocRef.Name
       Cells(Row, 2).Value = "'" & BlocRef.Handle
       
       ' On les récupére
       Attributes = BlocRef.GetAttributes
       
       ' On parcourt le tableau
       For j = LBound(Attributes) To UBound(Attributes)
         ' On recherche si une colonne existe déjà pour cette étiquette d'attribut
         Column = 3
         ColumnExist = False
         While Not IsEmpty(Cells(3, Column))
           If Cells(3, Column).Text = Attributes(j).TagString Then
             ' Une colonne existe, on la remplit avec la valeur de l'atribut
             Cells(Row, Column).Value = Attributes(j).TextString
             ColumnExist = True
           End If
           Column = Column + 1 ' On passe à la colonne suivante
         Wend
         
         If Not ColumnExist Then
           ' Aucune colonne n'existe, on en crée une et on la remplit
           Cells(3, Column).Value = Attributes(j).TagString
           Cells(Row, Column).Value = Attributes(j).TextString
         End If
         
       Next ' Attribut suivant
       
       Row = Row + 1 ' Ligne suivante
     End If
   End If
 Next
 
 MsgBox "Les attributs du dessin " & Cells(1, 1).Text & " ont été extraits avec succès."
End Sub

[x_all]

sans etre programmeur, pourquoi ne passe tu pas par SSMatch de (gile) pour faire un jeu de sélection des blocs dont le nom est celui qui t’intéresse

 

ça affranchi des tests sur le nom du bloc...

 

ou bien fouille dans cette routine pour voir comment on peut filtrer le nom du bloc ?

[Lommig]

Bonjour,

 

Dim FilterType(0) As Integer

Dim FilterData(0) As Variant

[...]

' On prépare un filtre de sélection sur les insertions de bloc

FilterType(0) = 0

FilterData(0) = "INSERT"

FiltersType = FilterType

FiltersData = FilterData

 

L'extrait précédent permet de définir un filtre de sélection.

Actuellement, la commande sélectionne toutes les références de blocs ( objet de type "INSERT" ).

Pour sélectionner seulement les blocs "Repère", on peut faire :

 

Dim FilterType(1) As Integer

Dim FilterData(1) As Variant

[...]

FilterType(0) = 0

FilterData(0) = "INSERT"

FilterType(1) = 2

FilterData(1) = "Repère"

FiltersType = FilterType

FiltersData = FilterData

 

Un article (en anglais) sur le sujet :

http://adndevblog.typepad.com/autocad/2012/07/vba-how-to-setup-selectionset-filters-for-a-block-or-layer.html

 

Guillaume

[DenisHen]

Il y a aussi _DATAEXTRACTION... Je m'en sert tous les jours en ce moment...

[Big666]

bonjour

à quoi sert t'il extraction de donner. ou?

mais ou et t'il

[DenisHen]

Il sert à faire un tableau Excel (par exemple) avec toutes les étiquettes des bloc. On peut y ajouter les XYZ du bloc, son échelle........

 

 

Denis...

[Big666]

bonjour

tu me le donne

[x_all]

c'est une fonction d'autocad

outil/extraction de données

 

[Big666]

je pense que c'etait un code vba!! vue la rubrique

 

je connaît extraction de donnée j'ai 2009 je ne suis pas si satisfait que ça.

cela mérite approfondie

merci

[KSJ77]

Merci beaucoup :)