CAD VBA 导出cass扩展数据到excel

cass中往往会写入扩展数据,但获取扩展数据较为麻烦,此例我们通过getxdata函数获取实体的扩展数据,然后逐要素循环写入excel中,代码如下:

版本1:要素扩展数据字段不同

复制代码
Sub 导出扩展数据到excel()
    Dim Excel As Object
    Dim elem As Object
    Dim excelSheet As Object
    Dim Array1 As Variant
    Dim xdataOut As Variant
    Dim xtypeOut As Variant
    Dim Count, RowNum As Integer
    Dim NumberOfAttributes As Integer
    
    ' Start Excel
    On Error Resume Next
    
    Set Excel = GetObject(, "Excel.Application")
    
    If Err <> 0 Then
        Err.Clear
        Set Excel = CreateObject("Excel.Application")
            
        If Err <> 0 Then
            MsgBox "Could not load Excel.", vbExclamation
            End
        End If
    End If
    
   
    
    Excel.Visible = True
    Excel.Workbooks.Add
    Excel.Sheets("Sheet1").Select
    Set excelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
    
    RowNum = 1
   
   For Each elem In ThisDrawing.ModelSpace
        If StrComp(elem.EntityName, "AcDbPolyline", 1) = 0 Then
            If elem.HasAttributes Then
 ''通过getattributes函数我们把块的属性放入数组中,下图可见数组有3个项目
 ''每个项目都有tagstring和textstring,然后把数组中值输出到excel,至此
 ''我们提取出了块中的全部属性
                elem.Highlight (True)
                elem.GetXData "", xtypeOut, xdataOut
                
                For Count = LBound(xtypeOut) To UBound(xtypeOut)
                   
                        If StrComp(xtypeOut(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                        
                            excelSheet.Cells(RowNum, Count + 1).Value = xtypeOut(Count)
                      
                        End If
                  
                Next Count
                RowNum = RowNum + 1
                For Count = LBound(xdataOut) To UBound(xdataOut)
                    excelSheet.Cells(RowNum, Count + 1).Value = xdataOut(Count)
                Next Count
              
            End If
             RowNum = RowNum + 1
        End If
       
    Next elem
    
    NumberOfAttributes = RowNum - 1
    
    If NumberOfAttributes > 0 Then
        excelSheet.UsedRange.Font.Bold = True
        
        'For a specific set of attribute information this could
        'be set to fit the exact number of columns.
        excelSheet.Columns("A:G").AutoFit

    Else
        MsgBox "未发现扩展数据" & Space(50) & vbCr & _
 "写代码qq:443440204", vbInformation, "版权所有qq:443440204"
        ''Excel.Quit
    End If
MsgBox "OK" & Space(50) & vbCr & _
 "vba代码二次开发qq:443440204", vbInformation, "版权所有qq:443440204"
End Sub

版本2:要素扩展数据字段相同

复制代码
Sub 导出扩展数据到excel()
    Dim Excel As Object
    Dim elem As Object
    Dim excelSheet As Object
     Dim xdataOut As Variant
    Dim xtypeOut As Variant
    Dim Count, RowNum As Integer
    Dim NumberOfAttributes As Integer
    
    ' Start Excel
    On Error Resume Next
    
    Set Excel = GetObject(, "Excel.Application")
    
    If Err <> 0 Then
        Err.Clear
        Set Excel = CreateObject("Excel.Application")
            
        If Err <> 0 Then
            MsgBox "不能加载Excel.", vbExclamation
            End
        End If
    End If
    

    
    Excel.Visible = True
    Excel.Workbooks.Add
    Excel.Sheets("Sheet1").Select
    Set excelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
    
    RowNum = 1
    Dim Header As Boolean
    For Each elem In ThisDrawing.ModelSpace
        
            If elem.HasAttributes Then
                 elem.Highlight (True)
                elem.GetXData "", xtypeOut, xdataOut
                For Count = LBound(xtypeOut) To UBound(xtypeOut)
                    If Header = False Then
                        If StrComp(xtypeOut(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                            excelSheet.Cells(RowNum, Count + 1).Value = xtypeOut(Count)
                        End If
                    End If
                Next Count
                RowNum = RowNum + 1
                For Count = LBound(xdataOut) To UBound(xdataOut)
                    excelSheet.Cells(RowNum, Count + 1).Value = xdataOut(Count)
                Next Count
                Header = True
            End If
        
    Next elem
    
    NumberOfAttributes = RowNum - 1
    
    If NumberOfAttributes > 0 Then
        excelSheet.UsedRange.Font.Bold = True
        
        'For a specific set of attribute information this could
        'be set to fit the exact number of columns.
        excelSheet.Columns("A:G").AutoFit

    Else
        MsgBox "未发现扩展数据" & Space(50) & vbCr & _
 "写代码qq:443440204", vbInformation, "版权所有qq:443440204"
        ''Excel.Quit
    End If
MsgBox "OK" & Space(50) & vbCr & _
 "vba代码二次开发qq:443440204", vbInformation, "版权所有qq:443440204"
End Sub
相关推荐
云心雨禅2 小时前
Vim操作指令全解析
编辑器·vim·excel
Source.Liu2 小时前
【学Rust写CAD】27 双线性插值函数(bilinear_interpolation.rs)
后端·rust·cad
安分小尧4 小时前
[特殊字符] 使用 Handsontable 构建一个支持 Excel 公式计算的动态表格
前端·javascript·react.js·typescript·excel
hello_simon7 小时前
在线小白工具,PPT转PDF支持多种热门工具,支持批量转换,操作简单,高效适合各种需求
pdf·html·powerpoint·excel·pdf转html·excel转pdf格式
Tttian62211 小时前
Python办公自动化(3)对Excel的操作
开发语言·python·excel
有趣的我16 小时前
vim的操作
编辑器·vim·excel
Source.Liu16 小时前
【学Rust写CAD】26 图形像素获取(pixel_fetch.rs)
rust·cad
woniu_maggie17 小时前
SAP EXCEL DOI 详解
开发语言·后端·excel
Dickson17 小时前
如何批量拆分Excel工作表或按行拆分Excel表格 - Excel拆分器使用方法
excel·excel拆分器·拆分excel·拆分excel工作表·按行拆分excel
inxunoffice21 小时前
批量将文本文件转换为 Word/PDF/Excel/图片等其它格式
pdf·word·excel