Here is some AutoCAD code to get you started (it is in AutoCAD 2004)
You will need to add a reference to Microsoft Excel in the VBA Project
All code is in the ThisDrawing Module
Option Explicit
Private ExcelApp As Excel.Application
Private Sub AcadDocument_ObjectAdded(ByVal Object As Object)
Dim objBlkRef As AcadBlockReference
Dim varInsPnt As Variant
Dim strHandle As String
'New Entity
'Add to Excel File
If TypeOf Object Is AcadBlockReference Then
Set objBlkRef = Object
varInsPnt = objBlkRef.InsertionPoint
strHandle = objBlkRef.Handle
If UpdateExcel(strHandle, varInsPnt, "New") = False Then
Debug.Print "There was an Error Updating Excel"
End If
End If
End Sub
Private Sub AcadDocument_ObjectModified(ByVal Object As Object)
Dim objBlkRef As AcadBlockReference
Dim varInsPnt As Variant
Dim strHandle As String
'Existing Entity
'Should be in Excel File
If TypeOf Object Is AcadBlockReference Then
Set objBlkRef = Object
varInsPnt = objBlkRef.InsertionPoint
strHandle = objBlkRef.Handle
If UpdateExcel(strHandle, varInsPnt, "Existing") = False Then
Debug.Print "There was an Error Updating Excel"
End If
End If
End Sub
Private Function UpdateExcel(sHandle As String, varpnt As Variant, sAction As String) As Boolean
Dim objWorkBook As Workbook
Dim objSheet As Worksheet
Dim objUsedRange As Range
Dim lngRows, lngRow As Long
Dim strFile As String
Dim blnFound As Boolean
Dim intcnt As Integer
On Error GoTo Err_Control
strFile = Replace(ThisDrawing.FullName, ".dwg", ".xlsx")
If ConnectToExcel = True Then
Set objWorkBook = ExcelApp.Workbooks.Open(strFile)
Set objSheet = objWorkBook.Worksheets(1)
Set objUsedRange = objSheet.UsedRange
'Get Last used row
lngRows = objUsedRange.Rows.Count + 1
Select Case sAction
Case "New"
'Add new blocks info
objSheet.Cells(lngRows, 1) = sHandle
For intcnt = LBound(varpnt) To UBound(varpnt)
objSheet.Cells(lngRows, intcnt + 2) = varpnt(intcnt)
Next
Case "Existing"
'Find Handle in Used Rows
For lngRow = 1 To lngRows - 1
If sHandle = objSheet.Cells(lngRow, 1) Then
For intcnt = LBound(varpnt) To UBound(varpnt)
objSheet.Cells(lngRow, intcnt + 2) = varpnt(intcnt)
Next
blnFound = True
End If
Next
If blnFound = False Then 'Didn't find it add it
objSheet.Cells(lngRows, 1) = sHandle
For intcnt = LBound(varpnt) To UBound(varpnt)
objSheet.Cells(lngRows, intcnt + 2) = varpnt(intcnt)
Next
End If
Case Else 'this should not happen unless you mistype the action name
End Select
objWorkBook.Save
objWorkBook.Close
Set ExcelApp = Nothing
UpdateExcel = True
End If
Exit_Here:
Exit Function
Err_Control:
Select Case Err.Number
Case 1004 'File doesn't exist (Not sure if anything else causes this error)
'create a new workbook and save as
Set objWorkBook = ExcelApp.Workbooks.Add
objWorkBook.SaveAs strFile
Resume
Case Else
Debug.Print Err.Number & ": " & Err.Description
Resume Exit_Here
End Select
End Function
Private Function ConnectToExcel() As Boolean
On Error GoTo Err_Control
Set ExcelApp = GetObject("Excel.Application")
ConnectToExcel = True
Exit_Here:
ExcelApp.AlertBeforeOverwriting = False
Exit Function
Err_Control:
Select Case Err.Number
Case Else
Set ExcelApp = CreateObject("Excel.Application")
ConnectToExcel = True
Resume Exit_Here
End Select
End Function