[VBA程序]：块属性导入到Excel中示例程序

efan2000 · 发表于 2003-11-30 22:14:02

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

[FONT=courier new]
'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
[/FONT]

[FONT=courier new] 
'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 
  [/FONT]

efan2000 · 发表于 2003-11-30 22:14:40

贴图。

efan2000 · 发表于 2003-11-30 22:17:39

晕，竟然不能传多个图片，会覆盖前面已经上传的。

efan2000 · 发表于 2003-11-30 22:18:23

呵呵，这招总可以了吧。

gjliang · 发表于 2003-12-1 08:39:32

厉害，老大，都写出来vba的了，我也拿来用用：）

kfygl · 发表于 2003-12-9 02:00:34

非常感谢斑竹的帮助！我不知到要安装哪一个软件才能看到图片，请继续帮助我。我是一只非常笨的老菜鸟,请不要笑我，请帮助我。

hxa · 发表于 2003-12-9 05:56:24

最初由 efan2000 发布
[B][CODE]

'frmBlock代码

Private Sub CommandButton1_Click()
If ListBox1.Text = "" Then Exit Sub
If ListBox2.ListCount = 0 Then Exit Sub
'返回选中的属性列表
Di... [/B]

好程序!

请楼主最好完善一下，使得块属性—Excel双向可导，即将块属性导入Excel，并在Excel中修改后再返回CAD中。

sdxylijian · 发表于 2003-12-12 00:06:09

真的很感谢，我正需要这些资料，感激到无言！！！

zzg123good · 发表于 2003-12-25 23:27:34

程序好长啊，一下子真不好理解。

passingwind · 发表于 2003-12-28 02:10:24

我把程序拿回去试，不懂的来问！

movie2003 · 发表于 2003-12-30 21:03:25

我正在找，实在是太感谢了

yfy2003 · 发表于 2004-1-28 18:38:56

感谢斑竹提供！

陌生人 · 发表于 2004-1-28 21:03:58

虽然我不懂vba，但是也鼓励支持一下。编程真不容易啊

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

[VBA程序]：块属性导入到Excel中示例程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

Re: [VBA程序]：块属性导入到Excel中示例程序