高手请进来看看这段 VBA代码

ananiviv · 发表于 2007-6-3 19:35

这段代码我找到时说明是可以将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

zhaoyanaaa · 发表于 2007-6-3 21:28

LNG123 · 发表于 2007-6-4 20:46

这个真的难说的
想当年用EXCEL宏的时候也经常出错
自己慢慢的去调试

		自动登录	找回密码
密码			立即注册

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