Excel和AutoCad之间的双向链接

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