[VBA]块属性导入到Excel。

efan2000 · 发表于 2003-11-30 22:05:00

'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

'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文件

截图

fayadetudou · 发表于 2023-10-31 10:15:56

挺好的。楼主是做什么工作的？

gzy · 发表于 2003-11-30 22:44:00

呵呵，好玩，不过看得还不大懂。

subtlation · 发表于 2003-12-1 09:15:00

程序写得挺好懂的。看程序也是学习啊。而且这个导出属性块有时还是能用到的。

XJ_HE · 发表于 2003-12-1 13:19:00

挺好的。楼主是做什么工作的？

我做室内覆盖。前段时间（还有你不少帮助呢）在写的时候，也想做成属性块。不过最后写了之后，文件规范化太难。（就是像耦合器，功分器均需按属性块来做，同事们不愿意，觉得麻烦。）最后用其它方法解决，但不准确。

efan2000 · 发表于 2003-12-1 13:32:00

呵呵，是我以前开发的一套有线电视方面的软件，这只是它的一个样图。
用属性块的好处是一个部件连同标注就是一个块，简单，属性修改方便。但是它也有缺点，属性的对齐、位置修改比较困难。
当然具体的应用场合不同，使用的方法也不一样。像这套软件，因为用户的标注样式简单、而且标注的文字位置就这几种，因而可以使用这种方式，我是通过程序全部控制。它自动计算前一连接设备的输出，这一设备的衰耗以及输出，最后自动生成标注，因而人工干预的情况比较少，适合于简单、大量录入的图纸。

XJ_HE · 发表于 2003-12-1 14:15:00

efan2000发表于2003-12-1 13:32:00当然具体的应用场合不同，使用的方法也不一样。像这套软件，“因为用户的标注样式简单、而且标注的文字位置就这几种，因而可以使用这种方式”，我是通过程序全部控制。“它自动计算前一连接设备

版主，你好。
   我现在也正在思考如何去完成输入一个总的功率，最后算出每层天线的输出功率。但是总觉得实现太困难。当然，主要是思路上面。您以前写过这种东东，而且和我们也挺相似的。如果可能，我想听听您当时的思路。
   在此谢谢了。

您可以先将您原来的文件（CAD图，EXCEL图）传上来一份吗？
或者发到我的邮箱里：xj_he@126.com  xj_he@163.com

efan2000 · 发表于 2003-12-1 20:15:00

To XJ_HE: 已经发到你的邮箱xj_he@163.com，没有Excel的。

在程序中添加了工具栏，在第一行运行之后，以后启动AutoCAD之后，单击按钮就可以自动加载工程。

XJ_HE · 发表于 2003-12-2 09:21:00

谢谢版主。
程序还得细看。属性块用的相当不错。或者将你的东东细分析，我可以找到自动计算功率的方法。

xuhuai714 · 发表于 2008-10-31 21:28:00

如果不是块怎么分类计算呢，我们总工做了一个用LISP算钢筋表的程序，好用要死，就是没有源程序，太可惜了，让他给弄没了！！！！！！（A1）10-23D16X1000就这样就能算出钢筋重量来，太厉害了，我是对日做配筋图，小日本的要求太严了，以前同事全是用EXCEL来算重量了，他开发这个程序出来，公司可以少顾二个员工了！！！

chshsl · 发表于 2008-12-19 08:32:00

楼上的，你们总工可真牛啊！一般总工结构技术好，电脑水平都不怎么要，毕敬年龄都大！

账号		自动登录	找回密码
密码			注册

[VBA]块属性导入到Excel。

本帖子中包含更多资源

评分

本帖被以下淘专辑推荐:

本帖子中包含更多资源