[求助]请进来看下这段VBA代码

ananiviv

这段代码 我找到时 说明是可以将AutoCAD中的属性块中的属性提取到Excel中
我用的是AUTOCAD2007 打开VBA复制进去 然后工具-引用，把Microsoft  Excel勾选上
然后编译   光标停留在“mspace As Object”这句上
编译报错  “成员已经存在于本对象模块派生出的对象模块中”
然后小弟查了很久 也不知道 对不对 把mspace改成了myspace
再编译就没有报错 通过了
但是运行宏的时候 又报错“运行时错误429，ActiveX部件不能创建对象”
请各位帮忙看一下 或者 高手可以指点一下小弟
感激万分

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, Array2 As Variant
    Dim Count As Integer

    Set excel = GetObject(, "Excel.Application")
Set excelSheet = excel.Worksheets("sheet1")
     Dim Sh As Object, rngStart As Range
     If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
     Set Sh1 = ExcelSheet1
Set rngStart = Sh1.Range("A1")
    With rngStart.Rows(1)
End With
    Set acad = Nothing
    On Error Resume Next
    Set acad = GetObject(, "AutoCAD.Application")
    If Err <> 0 Then
    Set acad = CreateObject("AutoCAD.Application")
    MsgBox "请打开 AutoCAD 图形文件!"
    Exit Sub
    End If

    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
              Array2 = .GetConstantAttributes
            For Count = LBound(Array1) To UBound(Array1)
               If Header = False Then
                 If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                  excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
                 End If
               End If
            Next Count
           
            For Count = LBound(Array2) To UBound(Array2)
               If Header = False Then
                 If StrComp(Array2(Count).EntityName, "AcDbAttributeDefinition", 1) = 0 Then
                  excelSheet.Cells(RowNum, UBound(Array1) + 1 + Count + 1).Value = Array2(Count).TagString
                 End If
               End If
            Next Count
           
              RowNum = RowNum + 1
            For Count = LBound(Array1) To UBound(Array1)
               excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
            Next Count
           
            For Count = LBound(Array2) To UBound(Array2)
               excelSheet.Cells(RowNum, UBound(Array1) + 1 + Count + 1).Value = Array2(Count).TextString
            Next Count
           
            Header = True
            End If
          End If
      End With
    Next elem
    NumberOfAttributes = RowNum - 1
    If NumberOfAttributes > 0 Then
      Worksheets("属性取出").Range("A1").Sort _
      key1:=Worksheets("属性取出").Columns("A"), _
      Header:=xlGuess
    Else
      MsgBox "无法提出图形文件中的属性或此图形文件中无任何属性！"
    End If
   
    Set currentcell = Range("A2")
    Do While Not IsEmpty(currentcell)
        Set nextCell = currentcell.Offset(1, 0)
        If nextCell.Value = currentcell.Value Then
            Set TCell = currentcell.Offset(1, 3)
            TCell.Value = TCell.Value + 1
            currentcell.EntireRow.Delete
        End If
        Set currentcell = nextCell
    Loop

   
    Set acad = Nothing
End Sub

wenwengg

去掉这句Public mspace As Object

ananiviv

已经尝试了 错误依然存在

wenwengg

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
    
    Set Excel = GetObject(, "Excel.Application")
'    Worksheets("Sheet1").Activate
    Set ExcelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
'    ExcelSheet.Range(Cells(1, 1), Cells(1000, 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")
        acad.Visible = True
        MsgBox "Please open a drawing file and then restart this macro."
        Exit Sub
    End If
    Set doc = acad.ActiveDocument
'    Set mspace = doc.ModelSpace
    Set mspace = doc.PaperSpace
    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
                                ExcelSheet.Cells(RowNum, count + 1).Value = Array1(count).TagString
                            End If
                        End If
                    Next count
                    RowNum = RowNum + 1
                    For count = LBound(Array1) To UBound(Array1)
                        ExcelSheet.Cells(RowNum, count + 1).Value = Array1(count).TextString
                    Next count
                    Header = True
                End If
            End If
        End With
    Next elem
    NumberOfAttributes = RowNum - 1
    If NumberOfAttributes > 0 Then
        Worksheets("Sheet1").Range("A1").Sort _
        Key1:=Worksheets("Sheet1").Columns("A"), _
        Header:=xlGuess
    Else
        MsgBox "No attributes found in the current drawing."
    End If
    Set acad = Nothing
End Sub

yanjun_lyg

这段程序是用在Excel的VBA中，且要把 Set Sh1 = ExcelSheet1改为 Set Sh1 = ExcelSheet