Hello:
Somebody would know to say to me where I have problema.
1º To Import attributes from AutoCAD with the macro "Exttr" from Autodesk.
2º To export with the macro "RestoreByHand" any modification that has made in the worsheet of excel to the drawing of AutoCAD it does not work
It's AutoCAD 2004.
I leave the code it in case they can help me, thanks beforehand.
Public acad 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
Dim SHand As String
Dim TStr As String
Set Excel = GetObject(, "Excel.Application")
Worksheets("Attributes").Activate
Set excelSheet = Excel.ActiveWorkbook.Sheets("Attributes")
excelSheet.Range(Cells(1, 1), Cells(5000, 100)).Clear
excelSheet.Range(Cells(1, 1), Cells(1, 100)).Font.Bold = True
Set acad = Nothing
On Error Resume Next
Set acad = GetObject(, "AutoCAD.Application")
If Err <> 0 Then
Set acad = CreateObject("AutoCAD.Application")
MsgBox "Open the drawing file first and then rexecute!"
Exit Sub
End If
acad.Visible = True
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
TStr = Array1(Count).TagString
excelSheet.Cells(RowNum, Count + 1).Value = TStr
End If
End If
Next Count
RowNum = RowNum + 1
For Count = LBound(Array1) To UBound(Array1)
TStr = Array1(Count).TextString
excelSheet.Cells(RowNum, Count + 1).Value = TStr
Next Count
SHand = elem.Handle
excelSheet.Cells(RowNum, Count + 1).NumberFormat = "@"
excelSheet.Cells(RowNum, Count + 1).Value = SHand
Header = True
End If
End If
End With
Next elem
NumberOfAttributes = RowNum - 1
Set acad = Nothing
End Sub
'_______________________________________________________________________________________
Sub RestoreByHand()
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
Dim SHand As String
Dim tempObj As Object
Set Excel = GetObject(, "Excel.Application")
Worksheets("Attributes").Activate
Set excelSheet = Excel.ActiveWorkbook.Sheets("Attributes")
Dim iLig As Integer
Dim ColHand As Long, LigHand1 As Long, LigHand2 As Long
Set acad = Nothing
On Error Resume Next
Set acad = GetObject(, "AutoCAD.Application")
If Err <> 0 Then
Set acad = CreateObject("AutoCAD.Application")
MsgBox "Open AutoCAD launch"
Exit Sub
End If
acad.Visible = True
Set doc = acad.ActiveDocument
Set mspace = doc.ModelSpace
RowNum = 1
Dim Header As Boolean
Header = False
ColHand = 17
LigHand1 = 1
LigHand2 = 10000
Dim iArray As Long
Dim jL As Long
iArray = 0
For iLig = LigHand1 To LigHand2
iArray = iArray + 1
SHand = excelSheet.Cells(iLig, ColHand).Value
If SHand <> "" Then
Set tempObj = doc.HandleToObject(SHand)
Array1 = tempObj.GetAttributes
For jL = 0 To 40
TStr = excelSheet.Cells(iLig, jL + 1).Value
Array1(jL).TextString = TStr
Next jL
End If
Next iLig
Set acad = Nothing
End Sub
