Modifier Extattr.xls

[Michel66]

Bonjour je souhaiterai un peu d'aide pour modifier le fichier Extattr.xls qui se trouve dans les exemples AutoCAD.

 

Mon projet est d'extraire des Mtext plutot que des Attributs..

à priori c'est plus simple, mais....

 

Voilà

 

 

thm29@cegetel.net

[didier]

Bonjour

 

Je ne vois pas à quoi tu fais référence,

car je n'ai pas de fichier XLS dans le répertoire Sample d'AutoCAd.

Ce n'est pas grave,

je te tape vite fait, donc sans contrôles,

une sub qui extrait la valeur contenue dans des TextMult,

ensuite on balance le tout dans Excel,

c'est bien ça ?

sinon, repose la question...

amicalement

 

Sub Extraire_TEXTMUL()

Dim Excel As Object

Dim Elem As Object

Dim ExcelSheet As Object

Dim Count, RowNum As Integer

 

On Error Resume Next

Set Excel = GetObject(, "Excel.Application")

If Err 0 Then

Err.Clear

Set Excel = CreateObject("Excel.Application")

If Err 0 Then

MsgBox "Impossible de lancer Excel.", vbExclamation

End

End If

End If

On Error GoTo 0

Excel.Visible = False 'True

Excel.Workbooks.Add

Excel.Sheets("Feuil1").Select

Set ExcelSheet = Excel.ActiveWorkbook.Sheets("Feuil1")

RowNum = 1

 

Dim ObjAcad As AcadApplication

Dim ObjSset As AcadSelectionSet

Set ObjAcad = GetObject(, "Autocad.Application")

ObjAcad.Visible = True

Set ObjSset = ObjAcad.ActiveDocument.SelectionSets.Add("JEU_SEL")

 

Call ObjSset.SelectOnScreen

 

For Each Elem In ObjSset

RowNum = RowNum + 1

ValeurEcrite = Elem.TextString

ExcelSheet.Cells(RowNum, 1).Value = ValeurEcrite

Next Elem

 

ObjSset.Delete

Excel.Visible = True

End Sub

[Pako]

Excel.Visible = False 'True

 

Excel.Visible = False

 

 

petite correction amicale ! :cool:

[Michel66]

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