[VBA]块属性导入到Excel。
'frmBlock代码
Private Sub CommandButton1_Click()
If ListBox1.Text = "" Then Exit Sub
If ListBox2.ListCount = 0 Then Exit Sub
'返回选中的属性列表
Dim s() As String
Dim i As Integer
Dim n As Integer
For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) Then
ReDim Preserve s(n)
s(n) = ListBox2.List(i)
n = n + 1
End If
Next
If n = 0 Then Exit Sub
On Error Resume Next
'启动Excel
Dim xlApp As Excel.Application
Set xlApp = GetObject(, "Excel.Application")
If Err Then
Err.Clear
Set xlApp = CreateObject("Excel.Application")
If Err Then
MsgBox "无法启动Excel，请检查系统！"
Err.Clear
Exit Sub
End If
End If
xlApp.Visible = True
On Error GoTo ErrTrap
'创建工作簿
Dim xlBook As Excel.Workbook
If xlApp.Workbooks.Count = 0 Then xlApp.Workbooks.Add
Set xlBook = xlApp.ActiveWorkbook
'设置工作表
Dim xlSheet As Excel.Worksheet
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Range(xlSheet.UsedRange.Address).ClearContents
On Error Resume Next
'创建选择集
Dim SSetObj As Object
Set SSetObj = ThisDrawing.SelectionSets("BlockCount")
If Err.Number <> 0 Then
Err.Clear
Set SSetObj = ThisDrawing.SelectionSets.Add("BlockCount")
End If
SSetObj.Clear
On Error GoTo ErrTrap
'创建过滤机制
Dim fType(0 To 1) As Integer
Dim fData(0 To 1) As Variant
fType(0) = 0: fData(0) = "INSERT"
fType(1) = 2: fData(1) = ListBox1.Text
'选择名称为Name的所有块
SSetObj.Select acSelectionSetAll, , , fType, fData
'删除数组
Erase fType: Erase fData
If SSetObj.Count = 0 Then Exit Sub
'输出块信息
xlSheet.Cells(1, 1) = "块名"
xlSheet.Cells(1, 2) = ListBox1.Text
xlSheet.Cells(1, 3) = "数目"
xlSheet.Cells(1, 4) = SSetObj.Count
'输出属性标题
For i = 0 To UBound(s)
xlSheet.Cells(2, i + 1) = s(i)
Next
'枚举选择集
Dim BlockRefObj As AcadBlockReference
Dim EntObj As AcadEntity
Dim AttRefs As Variant
Dim j As Integer
n = 3
For Each EntObj In SSetObj
If TypeOf EntObj Is AcadBlockReference Then
Set BlockRefObj = EntObj
If BlockRefObj.HasAttributes Then
AttRefs = BlockRefObj.GetAttributes
For i = 0 To UBound(AttRefs)
For j = 0 To UBound(s)
If AttRefs(i).TagString = s(j) Then
xlSheet.Cells(n, j + 1) = AttRefs(i).TextString
Exit For
End If
Next
Next
End If
n = n + 1
End If
Next
'删除选择集
SSetObj.Clear
SSetObj.Delete
Set EntObj = Nothing
Set BlockRefObj = Nothing
Set SSetObj = Nothing
Set xlSheet = Nothing
Set xlApp = Nothing
MsgBox "转换完毕! ", vbInformation
Exit Sub
ErrTrap:
MsgBox "出错了，请检查程序！"
On Error GoTo 0
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub ListBox1_Click()
If ListBox1.Text = "" Then Exit Sub
ListBox2.Clear
'列表框的当前位置
Dim idx As Integer
idx = ListBox1.ListIndex
'计算块的数目
If IsNull(ListBox1.List(idx, 1)) Then
ListBox1.List(idx, 1) = BlockCount(ListBox1.Text)
End If
'返回块
Dim BlockObj As AcadBlock
Set BlockObj = ThisDrawing.Blocks(ListBox1.Text)
'枚举属性
Dim AttObj As AcadAttribute
Dim EntObj As AcadEntity
For Each EntObj In BlockObj
If TypeOf EntObj Is AcadAttribute Then
Set AttObj = EntObj
ListBox2.AddItem AttObj.TagString
End If
Next
Set AttObj = Nothing
Set EntObj = Nothing
Set BlockObj = Nothing
End Sub
Private Sub UserForm_Initialize()
Dim v As Variant
Dim i As Integer
Dim j As Integer
On Error GoTo ErrTrap
'块名、数目
ListBox1.ColumnWidths = "50,25"
'枚举块名
Dim BlockObj As AcadBlock
For Each BlockObj In ThisDrawing.Blocks
'排除匿名块
If Left(BlockObj.Name, 1) <> "*" Then
ListBox1.AddItem BlockObj.Name
End If
Next
Set BlockObj = Nothing
Exit Sub
ErrTrap:
On Error GoTo 0
End Sub
'计算块的数目
Private Function BlockCount(ByVal Name As String) As Integer
BlockCount = 0
If Name = "" Then Exit Function
On Error Resume Next
'创建选择集
Dim SSetObj As Object
Set SSetObj = ThisDrawing.SelectionSets("BlockCount")
If Err.Number <> 0 Then
Err.Clear
Set SSetObj = ThisDrawing.SelectionSets.Add("BlockCount")
End If
SSetObj.Clear
On Error GoTo ErrTrap
'创建过滤机制
Dim fType(0 To 1) As Integer
Dim fData(0 To 1) As Variant
fType(0) = 0: fData(0) = "INSERT"
fType(1) = 2: fData(1) = Name
'选择名称为Name的所有块
SSetObj.Select acSelectionSetAll, , , fType, fData
'返回块的数目
BlockCount = SSetObj.Count
'删除数组
Erase fType: Erase fData
'删除选择集
SSetObj.Clear
SSetObj.Delete
Set SSetObj = Nothing
Exit Function
ErrTrap:
MsgBox "出错了，请检查程序！"
On Error GoTo 0
End Function
DVB文件，请使用R2000以上版本打开。
FRM文件
截图
挺好的。楼主是做什么工作的？ 呵呵，好玩，不过看得还不大懂。 程序写得挺好懂的。看程序也是学习啊。而且这个导出属性块有时还是能用到的。 挺好的。楼主是做什么工作的？
我做室内覆盖。前段时间（还有你不少帮助呢）在写的时候，也想做成属性块。不过最后写了之后，文件规范化太难。（就是像耦合器，功分器均需按属性块来做，同事们不愿意，觉得麻烦。）最后用其它方法解决，但不准确。 呵呵，是我以前开发的一套有线电视方面的软件，这只是它的一个样图。
用属性块的好处是一个部件连同标注就是一个块，简单，属性修改方便。但是它也有缺点，属性的对齐、位置修改比较困难。
当然具体的应用场合不同，使用的方法也不一样。像这套软件，因为用户的标注样式简单、而且标注的文字位置就这几种，因而可以使用这种方式，我是通过程序全部控制。它自动计算前一连接设备的输出，这一设备的衰耗以及输出，最后自动生成标注，因而人工干预的情况比较少，适合于简单、大量录入的图纸。 efan2000发表于2003-12-1 13:32:00static/image/common/back.gif当然具体的应用场合不同，使用的方法也不一样。像这套软件，“因为用户的标注样式简单、而且标注的文字位置就这几种，因而可以使用这种方式”，我是通过程序全部控制。“它自动计算前一连接设备
版主，你好。
我现在也正在思考如何去完成输入一个总的功率，最后算出每层天线的输出功率。但是总觉得实现太困难。当然，主要是思路上面。您以前写过这种东东，而且和我们也挺相似的。如果可能，我想听听您当时的思路。
在此谢谢了。
您可以先将您原来的文件（CAD图，EXCEL图）传上来一份吗？
或者发到我的邮箱里：xj_he@126.comxj_he@163.com To XJ_HE: 已经发到你的邮箱xj_he@163.com，没有Excel的。
在程序中添加了工具栏，在第一行运行之后，以后启动AutoCAD之后，单击按钮就可以自动加载工程。
谢谢版主。
程序还得细看。属性块用的相当不错。或者将你的东东细分析，我可以找到自动计算功率的方法。 如果不是块怎么分类计算呢，我们总工做了一个用LISP算钢筋表的程序，好用要死，就是没有源程序，太可惜了，让他给弄没了！！！！！！（A1）10-23D16X1000就这样就能算出钢筋重量来，太厉害了，我是对日做配筋图，小日本的要求太严了，以前同事全是用EXCEL来算重量了，他开发这个程序出来，公司可以少顾二个员工了！！！ 楼上的，你们总工可真牛啊！一般总工结构技术好，电脑水平都不怎么要，毕敬年龄都大！