利用vbscript进行PDM文件导出excle操作

背景描述

近期在做数据库设计，使用的软件是powerdesigner。当设计完成后，交给领导审阅，意外的发现，领导并没有powerdesigner软件，无法进行查看，于是领导让我转换格式后，再发给他，于是便有了转换pdm文件的操作路程，当然也可以导出为word文档，可能是我不会用，导出后看的内容有点乱，自己都没有看下去的欲望，何况领导呢，于是想这能不能生成直观的excle文档，每个表都清楚的展示出来，别带有其他冗余的说明，便找到了这个用脚本生成excle文档的代码，对于原作者的脚本做了一些改动，参考文档链接，感觉以后可能还会用得到，因此记录一下，也希望能帮到有需要的小伙伴。

vbscript脚本代码

相较原文链接的改动点如下：

1. 一个表设计一个sheet文件（源文件一个sheet页面，涵盖了所有的表设计信息）
2. sheet页名称为设计的表中文名称
3. 增加了对数据范围内边框的设置以及单元格高度宽度自适应的设置

' 当前脚本是对 PDM 数据库设置文件导出，并生成 excle 文件的执行脚本，因为 excle 的 sheet 页有限制，所以在大量表的情况下，应该会不适用（未验证过）
' 本人也不懂 vbscript 所以就不进行解释了，感兴趣的自己找资料，进行学习
Option Explicit
ValidationMode = True
InteractiveMode = im_Batch
' 获取当前焦点的对象
Dim mdl ' 当前焦点对象
Set mdl = ActiveModel
' 申请 excle 对象 和 sheet 行数对象
Dim EXCEL,rowsNum
'
If (mdl Is Nothing) Then
    MsgBox "There is no Active Model"
Else
	' 调用创建 excle 文档方法 
    SetExcel
	' 调用方法循环获取 pdm 文档中的表设计信息
    ListObjects(mdl)
End If

' 生成文档主要方法
Private Sub ListObjects(fldr)
    
    Dim obj ' 申请变量用于保存 pdm 文档中的每一个表设计信息对象
	' 开始执行循环体 fldr.children 即为当前工作环境下的表设计对象信息
    For Each obj In fldr.children
		SetSheet obj
    Next
    ' 进入到包的处理
    Dim f ' 递归处理每个包下边的表数据
    For Each f In fldr.Packages
        ' 递归调用开始（递归功能未校验）
        ListObjects f
    Next
End Sub
'-----------------------------------------------------------------------------
' 创建excle工作文档的方法
'-----------------------------------------------------------------------------
Private Sub SetExcel()
    Set EXCEL= CreateObject("Excel.Application")
 
    ' Make Excel visible through the Application object.
    EXCEL.Visible = True
    EXCEL.workbooks.add(-4167)'添加工作表
End Sub

'-----------------------------------------------------------------------------
' 创建excle文档 sheet 的方法
'-----------------------------------------------------------------------------

Sub SetSheet(obj)
	if not obj.Iskindof(cls_NamedObject) then exit sub
	if obj.Iskindof(cls_Table) then 
		rowsNum = 1
		Dim sheetName
		sheetName = obj.name
		' 指定当前 sheet 页的名称是当前设计表的中文名称
		EXCEL.workbooks(1).sheets(1).name = sheetName
		Dim sheet 
		' 获取当前的sheet页对象
		set sheet = EXCEL.workbooks(1).sheets(sheetName)
		' 这里将表的名称隐藏掉，如果需要，可以放开，col的值，需要调整，否则会覆盖
		' sheet.Cells(rowsNum, 1).Value = "表名"
		' sheet.Cells(rowsNum, 2).Value = "表中文名"
		' sheet.Cells(rowsNum, 3).Value = "表备注"
		sheet.Cells(rowsNum, 1).Value = "字段ID"
		sheet.Cells(rowsNum, 2).Value = "字段名"
		sheet.Cells(rowsNum, 3).Value = "字段中文名"
		sheet.Cells(rowsNum, 4).Value = "字段类型"
		sheet.Cells(rowsNum, 5).Value = "字段备注"
		ExportTable obj, sheet
		' 设置数据范围内，单元格高度、宽度自适应
		EXCEL.Range(sheet.Cells(1, 1), sheet.Cells(rowsNum, 5)).Select
		EXCEL.Selection.Rows.AutoFit
		EXCEL.Selection.Columns.AutoFit
		EXCEL.Selection.Rows.AutoFit
		' 给数据范围内的单元格加边框
		Dim range
		' 设置单元格边框范围
		range = "A1:E" & cstr(rowsNum)
		EXCEL.ActiveSheet.Range(range).Borders.Weight = 2
		' 给工作簿添加新的sheet页面，用于下一张表信息填充
		EXCEL.workbooks(1).sheets.add
	else 
		output "Found "+obj.ClassName+" """+obj.Name+""", Created by "+obj.Creator+" On "+Cstr(obj.CreationDate)
	End if
End Sub

' 填充 excle 表格的方法 
Sub ExportTable(tab, sheet)
    Dim col ' running column
    Dim colsNum
    colsNum = 0
    for each col in tab.columns
        colsNum = colsNum + 1
        rowsNum = rowsNum + 1
		' 对应的表头隐藏数据
        ' sheet.Cells(rowsNum, 1).Value = tab.code
        ' sheet.Cells(rowsNum, 2).Value = tab.name
        ' sheet.Cells(rowsNum, 3).Value = tab.comment
        sheet.Cells(rowsNum, 1).Value = colsNum
        sheet.Cells(rowsNum, 2).Value = col.code
        sheet.Cells(rowsNum, 3).Value = col.name
        sheet.Cells(rowsNum, 4).Value = col.datatype
        sheet.Cells(rowsNum, 5).Value = col.comment
    next
    output "Exported table: "+ +tab.Code+"("+tab.Name+")"
End Sub

执行方法

此处执行方法，使用图片展示，将代码复制运行即可

执行效果如下：