j'avais réaliser un programme me permettant d'extraire des attributs de bloc et de la classer sur un fichier Excel. Ce petit programme marché à merveille. Mais depuis que je suis passé sous Autocad 2016 il ne fonctionne plus. Le programme marche bien jusqu'à la sélection des objets sur Autocad, mais ne remplis plus le fichier Excel. Est ce que quelqu'un sais si il y a eu une mise à jour. Merci d'avance. si dessous le programme en question.
'Programmation Visual BASIC dans AutoCAD
Dim AcadDoc As Object, ExcelApp As Object, ExcelSheet As Excel.Worksheet, ExcelWorkBook As Excel.Workbooks
Private Sub Liste_Click()
Dim Collection As Object, Objet As Object
Dim i As Integer
Dim P As Variant, Attributes As Variant, Column As Integer, colonne As Integer, nom As Variant
Dim NombreTitres As Variant
Dim NombreBlocs As Variant
Dim NombreColone As Variant
Dim NombreLigne As Variant
Dim NomFichier As Variant
If MsgBox("Vous allez procéder à l'extraction des attributs. Attendez que Excel s'ouvre, puis sélectionner les éléments à métrer.", vbOKCancel) = vbOK Then
NomFichier = ActiveDocument.FullName
Dim Nonfichier As String
'ExcelApp est un lien sur l'application excel en cours
On Error Resume Next
'Verifie si Excel est ouvert et sinon l'ouvrir.
Set ObjExcel = GetObject(, "Excel.Application")
If Err.Number > 0 Then
Set ObjExcel = CreateObject("Excel.Application")
End If
ObjExcel.Visible = True
ObjExcel.Workbooks.Open ("C:\QAciers\Excel\QAciers.xlsm") 'ouvre le fichier Excel QAcier selon le chemin renseigné
ObjExcel.Application.Calculation = xlCalculationManual
ObjExcel.Worksheets("AutoCad").Range("A1:BZ60000").ClearContents ' Efface le contenu de la feuille AutoCad
ObjExcel.Worksheets("Autocad").Activate
ObjExcel.Sheets("Tableau de données").EnableSelection = xlUnlockedCells
ObjExcel.Sheets("Tableau de données").Protect Contents:=False
Set ExcelSheet = ObjExcel.ActiveWorkbook.Sheets("AutoCad")
'AcadDoc est un lien sur le dessin en cours
'Set AcadDoc = GetObject(, "Autocad.application").ActiveDocument
'On demande de selectionner sur le dessin les objjets
If ThisDrawing.SelectionSets.Count < 1 Then
Set ZoneChoix = ThisDrawing.SelectionSets.Add("jeu")
Else
Set ZoneChoix = ThisDrawing.SelectionSets.Item(0)
End If
ZoneChoix.Clear
ZoneChoix.SelectOnScreen
If ZoneChoix.Count < 1 Then ' si la zone de sélection contient des objets
Set Collection = ThisDrawing.ModelSpace
Else ' sinon prend tout le dessin
Set Collection = ZoneChoix
End If
'Remplissage sur la ligne n°1 de le feuille AutoCad avec les titre des de la feuilleExtraction
For x = 1 To 216
ExcelSheet.Cells(1, x) = ObjExcel.Sheets("Tableau de données").Cells(29, (x + 1)).Value
Next x
'collection représente l'ensemble des entités graphiques contenues dans l'espace objet
Set Collection = AcadDoc.ModelSpace
i = 2
'Pour chaque objet de la collection
For Each Objet In Collection
'Remplissage dans excel, ligne par ligne à partir de la deuxième
'ligne de la feuille, en indiquant l'identifiant, le type d'entité
If Objet.EntityType = 7 Then
nom = Objet.Name
NombreBlocs = ObjExcel.Sheets("Tableau de données").Range("HJ30").Value
NombreTitres = ObjExcel.Sheets("Tableau de données").Range("HJ29").Value
NombreLigne = (31 + NombreBlocs)
NombreColone = (1 + NombreTitres)
For z = 31 To NombreLigne
Select Case nom
Case ObjExcel.Sheets("Tableau de données").Cells(z, 1).Value
ExcelSheet.Cells(i, 200) = Objet.Handle
Attributes = Objet.GetAttributes
For J = 0 To UBound(Attributes)
For w = 1 To NombreColone
Select Case Attributes(J).TagString
Case ObjExcel.Sheets("Tableau de données").Cells(z, (w + 1)).Value: colonne = w
Case ObjExcel.Sheets("Tableau de données").Cells(z, 202).Value: colonne = 201
Case ObjExcel.Sheets("Tableau de données").Cells(z, 203).Value: colonne = 202
Case ObjExcel.Sheets("Tableau de données").Cells(z, 204).Value: colonne = 203
Case ObjExcel.Sheets("Tableau de données").Cells(z, 205).Value: colonne = 204
Case ObjExcel.Sheets("Tableau de données").Cells(z, 206).Value: colonne = 205
Case ObjExcel.Sheets("Tableau de données").Cells(z, 207).Value: colonne = 206
End Select
Next w
ExcelSheet.Cells(i, colonne) = Attributes(J).TextString
Next J
i = i + 1 'on passe à la ligne suivante pour le prochain
End Select
Next z
End If
Next
ObjExcel.Worksheets("Résultat").Activate
ExcelSheet.Cells(1, 215) = NomFichier
ObjExcel.Sheets("Tableau de données").EnableSelection = xlUnlockedCells
ObjExcel.Sheets("Tableau de données").Protect Contents:=True
ObjExcel.Sheets("Résultat").EnableSelection = xlUnlockedCells
ObjExcel.Sheets("Résultat").Protect Contents:=False
ObjExcel.Sheets("Résultat").Range("C4:E5").Interior.color = RGB(0, 255, 0)
ObjExcel.Sheets("Résultat").EnableSelection = xlUnlockedCells
ObjExcel.Sheets("Résultat").Protect Contents:=True
ObjExcel.Application.Calculation = xlCalculationAutomatic
Else
End If
End Sub