|
|
发表于 2007-5-8 21:52:00
|
显示全部楼层
Dim cName As String
Dim nHandle As String
Dim nScale As Double
Dim nRotation As Double
Dim sLayer As String
Dim yline As Integer
Dim ent As Object
Dim obname As String
Dim xy As Variant
Dim varattr As Variant
Dim attrtxt As Variant
On Error Resume Next
Dim Excel As Excel.Application '定义excle应用程序变量
'Dim ExcelSheet As Object
Dim ExcelWorkbook As Object '定义工作簿变量
Dim ExcelSheet As worksheet '定义工作表变量
Set Excel = CreateObject("excel.application") '激活excel程序
Excel.Workbooks.Open ("属性表.xls") '打开工作薄
Set ExcelSheet = Excel.ActiveWorkbook.Sheets("sheet1") '当前工作表为sheet1
'corow = ExcelSheet.UsedRange.Rows.count '计算工作表的总行数
'创建Excel应用程序实例
' Set Excel = GetObject(, "Excel.Application")
'创建一个新工作簿
' Set ExcelWorkbook = Excel.Workbooks.Add
'确保Sheet1工作表为当前工作表
' Set ExcelSheet = Excel.ActiveSheet
' Set ExcelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
'将新创建的工作簿保存为Excel文件
Excel.Visible = False
yline = 2 '写入行位置
For Each ent In ThisDrawing.ModelSpace '在模型空间里循环
obname = ent.ObjectName '提取对象类型
If obname = "AcDbBlockReference" Then '判断对象是否为块
cName = ent.Name '获取块名
xy = ent.InsertionPoint '获取插入点坐标
nHandle = ent.handle '获取块句柄
nScale = ent.XScaleFactor '获取比例
nRotation = ent.Rotation '获取角度
sLayer = ent.Layer
varattr = ent.GetAttributes ' 将块属性标记和值复制到varattr变量
attrtxt(0) = varattr(0).TextString '属性值 0
attrtxt(1) = varattr(1).TextString '属性值 1
attrtxt(2) = varattr(2).TextString '属性值 2
ExcelSheet.Cells(yline, 1).Value = nHandle
ExcelSheet.Cells(yline, 2).Value = cName
ExcelSheet.Cells(yline, 3).Value = xy(0)
ExcelSheet.Cells(yline, 4).Value = xy(1)
ExcelSheet.Cells(yline, 5).Value = xy(2)
ExcelSheet.Cells(yline, 6).Value = obname
ExcelSheet.Cells(yline, 7).Value = nScale
ExcelSheet.Cells(yline, 8).Value = nRotation
ExcelSheet.Cells(yline, 9).Value = sLayer
ExcelSheet.Cells(yline, 10).Value = attrtxt(0) '属性值 0 写入excle文件
ExcelSheet.Cells(yline, 11).Value = attrtxt(1) '属性值 1 写入excle文件
ExcelSheet.Cells(yline, 12).Value = attrtxt(2) '属性值 1 写入excle文件
yline = yline + 1 '位置加一行
attrtxt(0) = ""
attrtxt(1) = ""
attrtxt(2) = ""
End If
Next
Excel.Visible = True
Set Excel = Nothing '释放变量
Set ExcelSheet = Nothing |
|
置顶卡
