利用VBA把PowerDesigner导出到Excel
代码如下，有需要的同学直接复制就可用：
Option Explicit '------------------------------------------------------------------------------- '作用：PowerDesigner导出到Excel ' '作者: Lio5n ' '时间: 2015-12-17 ' '版本: V1.0 '------------------------------------------------------------------------------- '----------------------------------请按需设置----------------------------------- CONST GEN_MENU = "Y" '是否生成目录文件 [ Y-是 N-否 ] CONST MENU_FILE = "D:\File_Name.xlsx" '目录文件路径 CONST GEN_TABLE = "Y" '是否生成模型结构 [ Y-是 N-否 ] CONST SHOW_DISTRIBUTION_KEYS = "Y" '是否显示分布键 [ Y-是 N-否 ] '----------------------------------目录页设置----------------------------------- CONST COL_TABLE_CODE = "C" '表英文名列 CONST COL_TABLE_NAME = "D" '表中文名列 CONST COL_DEAL_FLAG = "E" '处理标志列 '------------------------------------------------------------------------------- CONST BEG_ROW = 6 '数据区域-开始行 CONST END_COL = "J" '数据区域-结束列 CONST MAX_TABLES = 1000 '表数量上限 CONST DATA_TYPE_DATE_LEN = 10 'DATE类型数据长度 CONST DATA_TYPE_TIMESTAMP_LEN = 19 'TIMESTAMP类型数据长度 CONST DATA_TYPE_INTEGER_LEN = 12 'INTEGER类型数据长度 CONST D_COLOR_BLUE = 16764057 '天蓝色 CONST D_COLOR_GREEN = 13434828 '浅绿色 CONST D_COLOR_ORAGNE = 49407 '橙色 Dim mCR,mLF mCR = Chr(10) '换行 mLF = Chr(13) '回车 '------------------------------------------------------------------------------- '定义PDM Dim mdl Dim errCount, errString errCount=0 Set mdl = ActiveModel If ( mdl Is Nothing ) Then MsgBox "There is no Active Model" Else If UCase(GEN_MENU) = "Y" Then createMenuSheet mdl '生成目录 End If If UCase(GEN_TABLE) = "Y" Then createTableSheet mdl '根据目录生成表结构 End If If errCount > 0 Then output "错误信息: " + errString End If MsgBox "处理完毕,共有"+Cstr(errCount)+"个错误!" End If '------------------------------------------------------------------------------- '生成目录 ' 序号|模式名|表名|处理标志(Y/N)|中文表名|备注 ' 处理标志默认全部为Y '------------------------------------------------------------------------------- sub createMenuSheet(mdl) Dim ExcelApp, ExcelBook, ExcelSheet Set ExcelApp = CreateObject("Excel.Application") ExcelApp.visible=FALSE Set ExcelBook = ExcelApp.Workbooks.Add Set ExcelSheet = ExcelBook.Sheets.Add ExcelSheet.Name = "目录" '目录标题栏 With ExcelSheet '内容 .Cells(1,"A").Value = "序号" .Cells(1,"B").Value = "模式名" .Cells(1,"C").Value = "表英文名" .Cells(1,"D").Value = "中文表名" .Cells(1,"E").Value = "处理标志(Y/N)" .Cells(1,"F").Value = "备注" '样式-居中 .Rows(1).HorizontalAlignment = 3 '左右居中 5-填充，左对齐，不会覆盖右边的单元格 .Rows(1).VerticalAlignment = 2 '上下居中 '样式-宽高 .Rows(1).RowHeight = 1/0.035 '高1厘米 .Columns(1).ColumnWidth = 5 '宽，单位：字符 .Columns(2).ColumnWidth = 6 .Columns(3).ColumnWidth = 31 .Columns(4).ColumnWidth = 41 .Columns(5).ColumnWidth = 9 .Columns(6).ColumnWidth = 21 '样式-四周边框 .Range("A1","F1").Borders(1).LineStyle = 1 .Range("A1","F1").Borders(2).LineStyle = 1 .Range("A1","F1").Borders(3).LineStyle = 1 .Range("A1","F1").Borders(4).LineStyle = 1 '样式-其他 .Rows(1).WrapText = True '自动换行 .Range("A1","F1").Interior.Color = D_COLOR_BLUE '背景色-天蓝色 .Range("A1","F1").Font.Size = 10 '字体 .Rows(1).Font.Bold = True '粗体 End With Dim rowCnt rowCnt = 2 '生成表清单 output "开始生成表清单..." ListObjects mdl,ExcelSheet,rowCnt '遍历模型 '样式-设置部分列为左右居中 With ExcelSheet .Columns(1).HorizontalAlignment = 3 '左右居中 .Columns(2).HorizontalAlignment = 3 '左右居中 .Columns(5).HorizontalAlignment = 3 '左右居中 End With '调整整个数据区域样式 Dim rowEnd rowEnd = rowCnt-1 '最后一行行号 With ExcelSheet.Range("A2","F"+Cstr(rowEnd)) .Borders(1).LineStyle = 1 '四周边框 .Borders(2).LineStyle = 1 .Borders(3).LineStyle = 1 .Borders(4).LineStyle = 1 End With ExcelSheet.Range("A1","F"+Cstr(rowEnd)).Font.Size = 10 '字体 '按层名、表名排序 ExcelApp.AddCustomList Array("ODM", "FDM", "ADM", "MDM", "PUBLIC") ExcelSheet.Sort.SortFields.Clear ExcelSheet.Sort.SortFields.Add ExcelSheet.Range("B2","B"+Cstr(rowEnd)), 0, 1, "ODM,FDM,ADM,DMD,PUBLIC", 0 ExcelSheet.Sort.SortFields.Add ExcelSheet.Range("C2","C"+Cstr(rowEnd)), 0, 1, "", 0 With ExcelSheet.Sort .SetRange ExcelSheet.Range("B1","F"+Cstr(rowEnd)) .Header = 1 .MatchCase = False .Apply End With '筛选 ExcelApp.Selection.AutoFilter '冻结首行 ExcelApp.ActiveWindow.SplitRow = 1 '行 ExcelApp.ActiveWindow.SplitColumn = 0 '列 ExcelApp.ActiveWindow.FreezePanes = True ExcelBook.SaveAs MENU_FILE ExcelBook.Close ExcelApp.Quit Set ExcelSheet = Nothing Set ExcelBook = Nothing Set ExcelApp = Nothing output "表清单生成完毕, 共 " + Cstr(rowCnt-2) + " 张表!" Exit Sub End Sub '遍历模型 Private Sub ListObjects(fldr,ExcelSheet,rowCnt) Dim obj For Each obj In fldr.children getTables fldr,obj,ExcelSheet,rowCnt Next Dim f For Each f In fldr.Packages ListObjects f,ExcelSheet,rowCnt Next End Sub '获取表清单 Private Sub getTables(CurrentFldr,CurrentObject,ExcelSheet,rowCnt) Dim col Dim colType If CurrentObject.IsKindOf(cls_Table) then ExcelSheet.Cells(rowCnt,"A").Value = rowCnt - 1 If ( CurrentObject.Owner Is Nothing ) Then ExcelSheet.Cells(rowCnt,"B").Value = "PUBLIC" Else ExcelSheet.Cells(rowCnt,"B").Value = CurrentObject.Owner.Code End If ExcelSheet.Cells(rowCnt,"C").Value = CurrentObject.Code ExcelSheet.Cells(rowCnt,"D").Value = CurrentObject.Name ExcelSheet.Cells(rowCnt,"E").Value = "Y" ExcelSheet.Cells(rowCnt,"F").Value = "" rowCnt = rowCnt + 1 else exit sub end if End Sub '------------------------------------------------------------------------------- '根据目录生成表结构，每个表一个Sheet。 '------------------------------------------------------------------------------- sub createTableSheet(mdl) Dim ExcelApp, ExcelBook, ExcelSheet, ExcelMenu Dim rowIdx, menuIdx Dim tableCnt, colCnt Dim tableNum Dim tableCode, tableName, tableOwner, tableFlag tableCnt = 0 tableNum = 0 '当用户指定目录文件时，重定义输出文件，以免生成过程中出错，或对输出结果不满意时，需要重新恢复目录文件。 Dim InputFile, OutputFile InputFile = MENU_FILE If UCase(GEN_MENU) = "N" Then OutputFile = Mid(InputFile, 1, InstrRev(InputFile,".")-1) + "_out" + Mid(InputFile, InstrRev(InputFile,".")) Else OutputFile = InputFile End If '读取目录文件 Set ExcelApp = CreateObject("Excel.Application") ExcelApp.visible=FALSE Set ExcelBook = ExcelApp.Workbooks.Open(MENU_FILE) Set ExcelMenu = ExcelBook.Sheets("目录") menuIdx = ExcelMenu.Index For rowIdx = 2 To MAX_TABLES+2 If ExcelMenu.Cells(rowIdx, "A").Value = "" Then Exit For Else tableNum = tableNum + 1 End If '获取表信息 tableOwner = ExcelMenu.Cells(rowIdx, "B").Value tableCode = ExcelMenu.Cells(rowIdx, COL_TABLE_CODE).Value tableName = ExcelMenu.Cells(rowIdx, COL_TABLE_NAME).Value tableFlag = ExcelMenu.Cells(rowIdx, COL_DEAL_FLAG).Value If UCase(tableFlag) = "Y" AND ( Len(tableCode)>0 OR Len(tableName)>0 ) Then '处理标志非Y则跳过 '检查表是否存在 Dim iFlag iFlag = 0 checkTable mdl,ExcelSheet,tableCode,tableName,iFlag '表存在则继续处理 If iFlag = 1 Then tableCnt = tableCnt + 1 '创建Sheet页 Set ExcelSheet = ExcelBook.Sheets.Add(,ExcelBook.Sheets(menuIdx)) '在目录后面插入，第一个参数为空 ExcelSheet.Name = tableCode output "["+Cstr(tableCnt)+"] "+tableCode '添加自定义名称 范围-工作簿 ExcelBook.Names.Add tableOwner+"."+tableCode,"="+ExcelMenu.Name+"!R"+Cstr(rowIdx)+"C3" 'R=row C=col R2C3=$2$3=C2 '生成表头 With ExcelSheet '第一行 .Cells(1,"A").Value = "<<返回目录" '超链接，指向自定义名称 .Hyperlinks.Add ExcelSheet.Range("A1"),"",tableOwner+"."+tableCode,"",ExcelSheet.Cells(1,"A").Value '超链接，直接定位到单元格，但这样的话，如果目标单元格发生变化，就跳错了。 '.Hyperlinks.Add ExcelSheet.Range("A1"),"",ExcelMenu.Name+"!C"+Cstr(rowIdx),"",ExcelSheet.Cells(1,"A").Value '第二行 .Cells(2,"A").Value = "英文名" .Range("B2","C2").Merge .Cells(2,"B").Value = tableCode .Cells(2,"D").Value = "模式名" .Cells(2,"E").Value = tableOwner '第三行 .Cells(3,"A").Value = "中文名" .Range("B3","E3").Merge .Cells(3,"B").Value = tableName '第四行 .Cells(4,"A").Value = "描述" .Range("B4","E4").Merge '设置样式-表头 .Range("A2","A4").Interior.Color = D_COLOR_GREEN '背景色-浅绿色 .Range("A2","A4").Font.Bold = True '粗体 .Range("A2","A4").HorizontalAlignment = 3 '左右居中 .Cells(2,"D").Interior.Color = D_COLOR_GREEN '背景色-浅绿色 .Cells(2,"D").Font.Bold = True '粗体 .Cells(2,"D").HorizontalAlignment = 3 '左右居中 .Range("A1","E4").Font.Size = 10 '字体 .Range("A2","E4").Borders(1).LineStyle = 1 '四周边框 .Range("A2","E4").Borders(2).LineStyle = 1 .Range("A2","E4").Borders(3).LineStyle = 1 .Range("A2","E4").Borders(4).LineStyle = 1 '第五行-标题栏 .Cells(5,"A").Value = "序号" .Cells(5,"B").Value = "字段中文名" .Cells(5,"C").Value = "字段英文名" .Cells(5,"D").Value = "字段类型" .Cells(5,"E").Value = "数据长度" .Cells(5,"F").Value = "主键" .Cells(5,"G").Value = "非空" .Cells(5,"H").Value = "分布键" .Cells(5,"I").Value = "说明" .Cells(5,"J").Value = "备注" '设置样式-第五行-标题栏 With .Range("A5","J5") .Interior.Color = D_COLOR_BLUE '背景色-天蓝色 .Font.Bold = True '粗体 .HorizontalAlignment = 3 '左右居中 .Font.Size = 10 '字体 .Borders(1).LineStyle = 1 '四周边框 .Borders(2).LineStyle = 1 .Borders(3).LineStyle = 1 .Borders(4).LineStyle = 1 End With End With '生成字段内容 colCnt=0 getColumns mdl,ExcelSheet,tableCode,colCnt '调整整个数据区域样式 Dim rowEnd rowEnd = colCnt+BEG_ROW-1 '最后一行行号 With ExcelSheet.Range("A"+Cstr(BEG_ROW),END_COL+Cstr(rowEnd)) .Borders(1).LineStyle = 1 '四周边框 .Borders(2).LineStyle = 1 .Borders(3).LineStyle = 1 .Borders(4).LineStyle = 1 End With ExcelSheet.Range("A"+Cstr(BEG_ROW),END_COL+Cstr(rowEnd)).Font.Size = 10 '字体-整个数据区域 ExcelSheet.Range("A"+Cstr(BEG_ROW),"A"+Cstr(rowEnd)).HorizontalAlignment = 3 '左右居中-序号 ExcelSheet.Range("F"+Cstr(BEG_ROW),"H"+Cstr(rowEnd)).HorizontalAlignment = 3 '左右居中-主键、非空、分布键 '创建目录中的超链接 ExcelMenu.Hyperlinks.Add ExcelMenu.Range(COL_TABLE_CODE+Cstr(rowIdx)),"",ExcelSheet.Name+"!A1","",ExcelSheet.Name ExcelMenu.Range(COL_TABLE_CODE+Cstr(rowIdx)).Font.Size = 10 '更新目录中的表中文名 ExcelMenu.Range(COL_TABLE_NAME+Cstr(rowIdx)).Value = tableName '设置宽度 With ExcelSheet .Columns("A:H").EntireColumn.AutoFit '前8列-自适应 .Columns(9).ColumnWidth = 30 '说明 宽，单位：字符 .Columns(10).ColumnWidth = 10 '备注 End With '拆分冻结单元格 ExcelApp.ActiveWindow.SplitRow = BEG_ROW-1 '行 ExcelApp.ActiveWindow.SplitColumn = 5 '列 ExcelApp.ActiveWindow.FreezePanes = True '是否显示分布键 If UCase(SHOW_DISTRIBUTION_KEYS) <> "Y" Then ExcelSheet.Columns(8).Delete '删除分布键列 End If End If End If Next '设置目录页为活动页面，效果：打开EXCEL时，首页为目录页面 ExcelMenu.Activate '筛选处理标志为Y的记录 ExcelMenu.Range("$A$1:$"+COL_DEAL_FLAG+"$"+Cstr(tableNum)).AutoFilter Asc(COL_DEAL_FLAG)-Asc("A")+1,"=Y" ExcelBook.SaveAs OutputFile '另存为输出文件 ExcelBook.Close ExcelApp.Quit Set ExcelMenu = Nothing Set ExcelSheet = Nothing Set ExcelBook = Nothing Set ExcelApp = Nothing output "输出文件为：[" + OutputFile + "]" Exit Sub End Sub '检查表是否存在 Sub checkTable(mdl,ExcelSheet,tableCode,tableName,iFlag) Dim tb If Len(tableCode) > 0 Then set tb = mdl.FindChildByCode(tableCode,cls_Table) If ( tb Is Nothing ) Then output "未找到表[" + tableCode + "]" errString = errString + mLF + "未找到表[" + tableCode + "]" errCount = errCount + 1 Else iFlag = 1 tableName = tb.Name End If Else set tb = mdl.FindChildByName(tableName,cls_Table) If ( tb Is Nothing ) Then output "未找到表[" + tableName + "]" errString = errString + mLF + "未找到表[" + tableName + "]" errCount = errCount + 1 Else iFlag = 1 tableCode = tb.Code End If End If End Sub '生成字段 Sub getColumns(mdl,ExcelSheet,tableCode,colCnt) Dim tb, col, rowIdx set tb = mdl.FindChildByCode(tableCode,cls_Table) '在模型中查找目标表 If ( tb Is Nothing ) Then output "未找到表[" + tableCode + "]" errString = errString + mLF + "未找到表[" + tableCode + "]" errCount = errCount + 1 End If Dim colDistributionKeys, dKeys, iKeys, iKeysFlag '分布键 Dim tPhysicalOptions, iIdx1, iIdx2, sStr1, sStr2 iKeysFlag = 0 If Len(tb.PhysicalOptions) > 0 Then tPhysicalOptions = Replace(UCase(tb.PhysicalOptions), mLF, "") '去换行 iIdx1 = Instr(tPhysicalOptions, "DISTRIBUTED") 'DISTRIBUTED在字符串中的位置 If iIdx1 > 0 Then sStr1 = Mid(tPhysicalOptions, iIdx1) '从distributed开始的子串 sStr2 = Mid(sStr1, 1, Instr(sStr1, ")")-1) 'distributed by (... 没有")" colDistributionKeys = Mid(sStr2, Instr(sStr2, "(")+1) '分布键子串，有多个的话逗号分隔 dKeys = Split( colDistributionKeys, "," ) '拆分成数组 iKeys = ubound(dKeys) '数组最大下标 iKeysFlag = 1 End If End If rowIdx = 5 For Each col In tb.Columns rowIdx = rowIdx + 1 colCnt = colCnt + 1 '单元格-中英文表名、数据类型、长度 ExcelSheet.Cells(rowIdx,"A").Value = colCnt ExcelSheet.Cells(rowIdx,"B").Value = col.Name ExcelSheet.Cells(rowIdx,"C").Value = col.Code ExcelSheet.Cells(rowIdx,"D").Value = col.DataType ExcelSheet.Cells(rowIdx,"E").Value = col.Length '截取字段类型 Dim colType, strPair If Len(col.DataType) > 0 Then strPair = Split( col.DataType, "(" ) colType = strPair(0) Else colType = "" output "表[" + tableCode + "] 字段["+ col.Name + "] 类型为空！" errString = errString + mLF + "表[" + tableCode + "] 字段["+ col.Name + "] 类型为空！" errCount = errCount + 1 End If '根据字段类型，获取数据长度，CHAR类型的PDM自带长度，不需另外处理 If UCase(colType) = "DATE" Then ExcelSheet.Cells(rowIdx,"E").Value = DATA_TYPE_DATE_LEN End If If UCase(colType) = "TIMESTAMP" Then ExcelSheet.Cells(rowIdx,"E").Value = DATA_TYPE_TIMESTAMP_LEN End If If UCase(colType) = "INTEGER" Then ExcelSheet.Cells(rowIdx,"E").Value = DATA_TYPE_INTEGER_LEN End If If UCase(colType) = "DECIMAL" Or UCase(colType) = "NUMERIC" Then '20150728 新增NUMERIC判断 Dim str1, str2, colLen str1 = Split( strPair(1), ")" ) '截取括号内的值，如15,2或8 str2 = Split( str1(0), "," ) '截取总长度 colLen = str2(0) ExcelSheet.Cells(rowIdx,"E").Value = Cint(colLen)+2 End If '单元格-主键 If col.Primary = true Then ExcelSheet.Cells(rowIdx,"F").Value = "Y" End If '单元格-非空 If col.Mandatory = true Then ExcelSheet.Cells(rowIdx,"G").Value = "Y" End If '单元格-分布键 If iKeysFlag = 1 Then Dim keyIdx For keyIdx = 0 To iKeys If col.Code = Trim(dKeys(keyIdx)) Then ExcelSheet.Cells(rowIdx,"H").Value = "Y" Exit For End If Next End If '单元格-说明 ExcelSheet.Cells(rowIdx,"I").Value = col.Comment Next Exit Sub End Sub
