（求助）块属性提取
怎样提取块的插入点坐标？？下面的程序可以提取快标记和属性值
望大侠帮忙修改一下，可以提取插入点坐标
谢谢！！
Sub Ch12_Extract()
Dim Excel As Excel.Application
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object
Dim RowNum As Integer
Dim Header As Boolean
Dim elem As AcadEntity
Dim Array1 As Variant
Dim Count As Integer
' 启动 Excel。
Set Excel = New Excel.Application
' 创建新的工作簿并查找活动电子表格。
Set ExcelWorkbook = Excel.Workbooks.Add
Set ExcelSheet = Excel.ActiveSheet
ExcelWorkbook.SaveAs "Attribute.xls"
RowNum = 1
Header = False
' 遍历模型空间，查找
' 所有的块引用。
For Each elem In ThisDrawing.ModelSpace
With elem
' 找到块引用时，
' 检查其属性
If StrComp(.EntityName, "AcDbBlockReference", 1) _
= 0 Then
If .HasAttributes Then
' 获取属性
Array1 = .GetAttributes
' 将属性的标记字符串
' 复制到 Excel
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
Excel.Application.Quit
End Sub
dim v as variant
For Each elem In ThisDrawing.ModelSpace
With elem
If StrComp(.EntityName, "AcDbBlockReference", 1)= 0 Then
v=.InsertionPoint
ExcelSheet.Cells(RowNum,1).value = v(0)
ExcelSheet.Cells(RowNum,2).value = v(1)
ExcelSheet.Cells(RowNum,3).value = v(2)
RowNum = RowNum + 1
End If
End With
Next elem
自己顶 thanks 学习中 学习学习{:1_1:}{:1_1:}{:1_1:}
页:
[1]