高手请进来看看这段 VBA代码
这段代码 我找到时 说明是可以将AUTOCAD中的属性块中的属性提取到Excel中我用的是AUTOCAD2007 打开VBA复制进去 然后工具-引用，把MicrosoftExcel勾选上
然后编译 光标停留在“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 :) :( :D :'( :@ :o 这个真的难说的
想当年用EXCEL宏的时候也经常出错
自己慢慢的去调试
页:
[1]