Merci beaucoup :o) le fichier ExcelAtt se trouve bien dans le répertoire sample/ActiveX le voici ' ActiveX Sample ' ' Copyright © 1997, 1999, 2002 by Autodesk, Inc. ' ' Permission to use, copy, modify, and distribute this software ' for any purpose and without fee is hereby granted, provided ' that the above copyright notice appears in all copies and ' that both that copyright notice and the limited warranty and ' restricted rights notice below appear in all supporting ' documentation. ' ' AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS. ' AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF ' MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. AUTODESK, INC. ' DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE ' UNINTERRUPTED OR ERROR FREE. ' ' Use, duplication, or disclosure by the U.S. Government is subject to ' restrictions set forth in FAR 52.227-19 (Commercial Computer ' Software - Restricted Rights) and DFAR 252.227-7013©(1)(ii) ' (Rights in Technical Data and Computer Software), as applicable. Public AutoCAD As Object Public mspace As Object Public excel As Object Public AcadRunning As Integer Public excelSheet As Object Sub Extract() Dim sheet As Object Dim shapes As Object Dim elem As Object Dim excel As Object Dim Max As Integer Dim Min As Integer Dim NoOfIndices As Integer Dim excelSheet As Object Dim RowNum As Integer Dim Array1 As Variant Dim Count As Integer Set excel = GetObject(, "Excel.Application") Worksheets("Attributes").Activate Set excelSheet = excel.ActiveWorkbook.Sheets("Attributes") excelSheet.Range(Cells(1, 1), Cells(1000, 100)).Clear excelSheet.Range(Cells(1, 1), Cells(1, 100)).Font.Bold = True Set AutoCAD = Nothing On Error Resume Next Set AutoCAD = GetObject(, "AutoCAD.Application") If Err <> 0 Then Set AutoCAD = CreateObject("AutoCAD.Application") AutoCAD.Visible = True MsgBox "Please open a drawing file and then restart this macro." Exit Sub End If Set doc = acad.ActiveDocument Set mspace = doc.ModelSpace RowNum = 1 Dim Header As Boolean Header = False For Each elem In mspace With elem If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then If .HasAttributes Then Array1 = .GetAttributes For Count = LBound(Array1) To UBound(Array1) If Header = False Then If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString End If End If Next Count RowNum = RowNum + 1 For Count = LBound(Array1) To UBound(Array1) excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString Next Count Header = True End If End If End With Next elem NumberOfAttributes = RowNum - 1 If NumberOfAttributes > 0 Then Worksheets("Attributes").Range("A1").Sort _ key1:=Worksheets("Attributes").Columns("A"), _ Header:=xlGuess Else MsgBox "No attributes found in the current drawing." End If Set AutoCAD = Nothing End Sub Private Sub Auto_Close() Set excelSheet = Nothing End Sub Je pense que je me débrouillerai avec votre fichier et celui ci (enfin j'espère) Merci
