[求助]请进来看下这段VBA代码
<p>这段代码 我找到时 说明是可以将AUTOCAD中的属性块中的属性提取到Excel中<br/>我用的是AUTOCAD2007 打开VBA复制进去 然后工具-引用，把Microsoft Excel勾选上<br/>然后编译 光标停留在“mspace As Object”这句上 <br/>编译报错 “成员已经存在于本对象模块派生出的对象模块中”<br/>然后小弟查了很久 也不知道 对不对 把mspace改成了myspace<br/>再编译就没有报错 通过了<br/>但是运行宏的时候 又报错“运行时错误429，ActiveX部件不能创建对象”<br/>请各位帮忙看一下 或者 高手可以指点一下小弟<br/>感激万分</p><p><br/>Public acad As Object<br/>Public mspace As Object<br/>Public excel As Object<br/>Public AcadRunning As Integer<br/>Public excelSheet As Object<br/>Sub Extract()<br/> Dim sheet As Object<br/> Dim shapes As Object<br/> Dim elem As Object<br/> Dim excel As Object<br/> Dim Max As Integer<br/> Dim Min As Integer<br/> Dim NoOfIndices As Integer<br/> Dim excelSheet As Object<br/> Dim RowNum As Integer<br/> Dim Array1 As Variant, Array2 As Variant<br/> Dim Count As Integer</p><p></p><p> Set excel = GetObject(, "Excel.Application")<br/>Set excelSheet = excel.Worksheets("sheet1")<br/> Dim Sh As Object, rngStart As Range<br/> If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub<br/> Set Sh1 = ExcelSheet1<br/>Set rngStart = Sh1.Range("A1")<br/> With rngStart.Rows(1)<br/>End With<br/> Set acad = Nothing<br/> On Error Resume Next<br/> Set acad = GetObject(, "AutoCAD.Application")<br/> If Err <> 0 Then<br/> Set acad = CreateObject("AutoCAD.Application")<br/> MsgBox "请打开 AutoCAD 图形文件!"<br/> Exit Sub<br/> End If</p><p> Set doc = acad.ActiveDocument<br/> Set mspace = doc.ModelSpace<br/> RowNum = 1<br/> Dim Header As Boolean<br/> Header = False<br/> For Each elem In mspace<br/> With elem<br/> If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then<br/> If .HasAttributes Then<br/> Array1 = .GetAttributes<br/> Array2 = .GetConstantAttributes<br/> For Count = LBound(Array1) To UBound(Array1)<br/> If Header = False Then<br/> If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then<br/> excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString<br/> End If<br/> End If<br/> Next Count<br/> <br/> For Count = LBound(Array2) To UBound(Array2)<br/> If Header = False Then<br/> If StrComp(Array2(Count).EntityName, "AcDbAttributeDefinition", 1) = 0 Then<br/> excelSheet.Cells(RowNum, UBound(Array1) + 1 + Count + 1).Value = Array2(Count).TagString<br/> End If<br/> End If<br/> Next Count<br/> <br/> RowNum = RowNum + 1<br/> For Count = LBound(Array1) To UBound(Array1)<br/> excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString<br/> Next Count<br/> <br/> For Count = LBound(Array2) To UBound(Array2)<br/> excelSheet.Cells(RowNum, UBound(Array1) + 1 + Count + 1).Value = Array2(Count).TextString<br/> Next Count<br/> <br/> Header = True<br/> End If<br/> End If<br/> End With<br/> Next elem<br/> NumberOfAttributes = RowNum - 1<br/> If NumberOfAttributes > 0 Then<br/> Worksheets("属性取出").Range("A1").Sort _<br/> key1:=Worksheets("属性取出").Columns("A"), _<br/> Header:=xlGuess<br/> Else<br/> MsgBox "无法提出图形文件中的属性或此图形文件中无任何属性！"<br/> End If<br/> <br/> Set currentcell = Range("A2")<br/> Do While Not IsEmpty(currentcell)<br/> Set nextCell = currentcell.Offset(1, 0)<br/> If nextCell.Value = currentcell.Value Then<br/> Set TCell = currentcell.Offset(1, 3)<br/> TCell.Value = TCell.Value + 1<br/> currentcell.EntireRow.Delete<br/> End If<br/> Set currentcell = nextCell<br/> Loop</p><p> <br/> Set acad = Nothing<br/>End Sub</p> <p>去掉这句Public mspace As Object</p> <p>已经尝试了 错误依然存在</p> <p>Sub Extract()<br/> Dim sheet As Object<br/> Dim shapes As Object<br/> Dim elem As Object<br/> Dim Excel As Object<br/> Dim Max As Integer<br/> Dim Min As Integer<br/> Dim NoOfIndices As Integer<br/> Dim ExcelSheet As Object<br/> Dim RowNum As Integer<br/> Dim Array1 As Variant<br/> Dim count As Integer<br/> <br/> Set Excel = GetObject(, "Excel.Application")<br/>' Worksheets("Sheet1").Activate<br/> Set ExcelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")<br/>' ExcelSheet.Range(Cells(1, 1), Cells(1000, 100)).Clear<br/>' ExcelSheet.Range(Cells(1, 1), Cells(1, 100)).Font.Bold = True<br/> Set acad = Nothing<br/> On Error Resume Next<br/> Set acad = GetObject(, "AutoCAD.Application")<br/> If Err <> 0 Then<br/> Set acad = CreateObject("AutoCAD.Application")<br/> acad.Visible = True<br/> MsgBox "Please open a drawing file and then restart this macro."<br/> Exit Sub<br/> End If<br/> Set doc = acad.ActiveDocument<br/>' Set mspace = doc.ModelSpace<br/> Set mspace = doc.PaperSpace<br/> RowNum = 1<br/> Dim Header As Boolean<br/> Header = False<br/> For Each elem In mspace<br/> With elem<br/> If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then<br/> If .HasAttributes Then<br/> Array1 = .GetAttributes<br/> For count = LBound(Array1) To UBound(Array1)<br/> If Header = False Then<br/> If StrComp(Array1(count).EntityName, "AcDbAttribute", 1) = 0 Then<br/> ExcelSheet.Cells(RowNum, count + 1).Value = Array1(count).TagString<br/> End If<br/> End If<br/> Next count<br/> RowNum = RowNum + 1<br/> For count = LBound(Array1) To UBound(Array1)<br/> ExcelSheet.Cells(RowNum, count + 1).Value = Array1(count).TextString<br/> Next count<br/> Header = True<br/> End If<br/> End If<br/> End With<br/> Next elem<br/> NumberOfAttributes = RowNum - 1<br/> If NumberOfAttributes > 0 Then<br/> Worksheets("Sheet1").Range("A1").Sort _<br/> Key1:=Worksheets("Sheet1").Columns("A"), _<br/> Header:=xlGuess<br/> Else<br/> MsgBox "No attributes found in the current drawing."<br/> End If<br/> Set acad = Nothing<br/>End Sub</p><p><br/></p> <p>这段程序是用在Excel的VBA中，且要把 Set Sh1 = ExcelSheet1改为 Set Sh1 = ExcelSheet</p>
页:
[1]