文章目录
背景描述
近期在做数据库设计,使用的软件是powerdesigner。当设计完成后,交给领导审阅,意外的发现,领导并没有powerdesigner软件,无法进行查看,于是领导让我转换格式后,再发给他,于是便有了转换pdm文件的操作路程,当然也可以导出为word文档,可能是我不会用,导出后看的内容有点乱,自己都没有看下去的欲望,何况领导呢,于是想这能不能生成直观的excle文档,每个表都清楚的展示出来,别带有其他冗余的说明,便找到了这个用脚本生成excle文档的代码,对于原作者的脚本做了一些改动,参考文档链接,感觉以后可能还会用得到,因此记录一下,也希望能帮到有需要的小伙伴。
vbscript脚本代码
相较原文链接的改动点如下:
- 一个表设计一个sheet文件(源文件一个sheet页面,涵盖了所有的表设计信息)
- sheet页名称为设计的表中文名称
- 增加了对数据范围内边框的设置以及单元格高度宽度自适应的设置
' 当前脚本是对 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
执行方法
此处执行方法,使用图片展示,将代码复制运行即可
执行效果如下: