Set objSelection = ThisDrawing.SelectionSets.Add("MySelection"),命名选择集已经存在
时间: 2023-08-22 22:04:26 浏览: 42
这个错误是因为您在创建选择集时使用了一个已经存在的名称。AutoCAD 中的选择集名称必须是唯一的,如果您使用了一个已经存在的名称,就会出现这个错误。您可以尝试修改选择集的名称,或者删除已经存在的选择集后再创建。以下是两种解决方法:
1. 修改选择集名称
```
Sub ExportToExcel()
Dim objExcel As New Excel.Application
Dim objWorkbook As Excel.Workbook
Dim objWorksheet As Excel.Worksheet
Dim objSelection As AcadSelectionSet
Dim objEntity As AcadEntity
'选择需要导出的图元
Set objSelection = ThisDrawing.SelectionSets.Add("MySelection_1") '修改选择集名称
objSelection.Select acSelectionSetAll, , , Array()
'创建Excel工作簿和工作表
Set objWorkbook = objExcel.Workbooks.Add
Set objWorksheet = objWorkbook.Worksheets.Add
'输入表头
objWorksheet.Cells(1, 1).Value = "图元类型"
objWorksheet.Cells(1, 2).Value = "图元名称"
objWorksheet.Cells(1, 3).Value = "图元颜色"
'循环读取图元信息并输入到Excel表中
For Each objEntity In objSelection
objWorksheet.Cells(objWorksheet.UsedRange.Rows.Count + 1, 1).Value = objEntity.ObjectName
objWorksheet.Cells(objWorksheet.UsedRange.Rows.Count, 2).Value = objEntity.Name
objWorksheet.Cells(objWorksheet.UsedRange.Rows.Count, 3).Value = objEntity.TrueColor.ColorIndex
Next objEntity
'保存Excel工作簿并退出
objWorkbook.SaveAs "C:\MyExcelFile.xlsx"
objWorkbook.Close
objExcel.Quit
'清除选择集
objSelection.Delete
End Sub
```
2. 删除已经存在的选择集
```
Sub ExportToExcel()
Dim objExcel As New Excel.Application
Dim objWorkbook As Excel.Workbook
Dim objWorksheet As Excel.Worksheet
Dim objSelection As AcadSelectionSet
Dim objEntity As AcadEntity
'删除已经存在的选择集
On Error Resume Next
ThisDrawing.SelectionSets.Item("MySelection").Delete
On Error GoTo 0
'创建新的选择集
Set objSelection = ThisDrawing.SelectionSets.Add("MySelection")
objSelection.Select acSelectionSetAll, , , Array()
'创建Excel工作簿和工作表
Set objWorkbook = objExcel.Workbooks.Add
Set objWorksheet = objWorkbook.Worksheets.Add
'输入表头
objWorksheet.Cells(1, 1).Value = "图元类型"
objWorksheet.Cells(1, 2).Value = "图元名称"
objWorksheet.Cells(1, 3).Value = "图元颜色"
'循环读取图元信息并输入到Excel表中
For Each objEntity In objSelection
objWorksheet.Cells(objWorksheet.UsedRange.Rows.Count + 1, 1).Value = objEntity.ObjectName
objWorksheet.Cells(objWorksheet.UsedRange.Rows.Count, 2).Value = objEntity.Name
objWorksheet.Cells(objWorksheet.UsedRange.Rows.Count, 3).Value = objEntity.TrueColor.ColorIndex
Next objEntity
'保存Excel工作簿并退出
objWorkbook.SaveAs "C:\MyExcelFile.xlsx"
objWorkbook.Close
objExcel.Quit
'清除选择集
objSelection.Delete
End Sub
```
无论是修改选择集名称还是删除已经存在的选择集后再创建,都可以解决这个问题。