从Excel更新属性

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