powerdesigner vb PDM 生成excel

'******************************************************************************   
'* File:     pdm2excel.txt   
'* Title:    pdm export to excel   
'* Purpose:  To export the tables and columns to Excel   
'* Model:    Physical Data Model   
'* Objects:  Table, Column, View   
'* Author:   Chirs   
'* Created:  2015-01-28   
'* Version:  1.0   
'******************************************************************************   
Option Explicit   
   Dim rowsNum   
   rowsNum = 0   
'-----------------------------------------------------------------------------   
' Main function   
'-----------------------------------------------------------------------------   
' Get the current active model   
Dim Model   
Set Model = ActiveModel   
If (Model Is Nothing) Or (Not Model.IsKindOf(PdPDM.cls_Model)) Then   
  MsgBox "The current model is not an PDM model."   
Else   
 ' Get the tables collection   
 '创建EXCEL APP   
  
  
Dim beginrow  
 Dim EXCEL, BOOK, SHEET  
 Set EXCEL = CreateObject("Excel.Application")  
 EXCEL.Visible = True  
 Set BOOK = EXCEL.Workbooks.Add(-4167) '新建工作簿  
  
 BOOK.Sheets(1).Name = "数据库表结构"  
 Set SHEET = EXCEL.workbooks(1).sheets("数据库表结构")  
  
 ShowProperties Model, SHEET  
 EXCEL.visible = true   
 '设置列宽和自动换行   
 SHEET.Columns(1).ColumnWidth = 10     
 SHEET.Columns(2).ColumnWidth = 30     
 SHEET.Columns(3).ColumnWidth = 20     
  
 SHEET.Columns(1).WrapText =true   
 SHEET.Columns(2).WrapText =true   
 SHEET.Columns(3).WrapText =true   
  
End If  
  
'-----------------------------------------------------------------------------   
' Show properties of tables   
'-----------------------------------------------------------------------------   
Sub ShowProperties(mdl, sheet)   
   ' Show tables of the current model/package   
   rowsNum=0   
   beginrow = rowsNum+1   
   ' For each table   
   output "begin"   
   Dim tab   
   For Each tab In mdl.tables   
      ShowTable tab,sheet   
   Next   
   if mdl.tables.count > 0 then   
        sheet.Range("A" & beginrow + 1 & ":A" & rowsNum).Rows.Group   
   end if   
   output "end"   
End Sub  
  
'-----------------------------------------------------------------------------   
' 数据表查询   
'-----------------------------------------------------------------------------  
Sub ShowTable(tab, sheet)     
   If IsObject(tab) Then   
     Dim rangFlag  
      sheet.cells(1, 1) = "序号"   
      sheet.cells(1, 2) = "表名"  
      sheet.cells(1, 3) = "实体名"  
      '设置边框   
      sheet.Range(sheet.cells(1, 1),sheet.cells(1, 3)).Borders.LineStyle = "1"  
      '设置背景颜色  
      sheet.Range(sheet.cells(1, 1),sheet.cells(1, 3)).Interior.ColorIndex = "19"  
  
      rowsNum = rowsNum + 1  
      sheet.cells(rowsNum+1, 1) = rowsNum   
      sheet.cells(rowsNum+1, 2) = tab.code  
      sheet.cells(rowsNum+1, 3) = tab.name  
      '设置边框  
      sheet.Range(sheet.cells(rowsNum+1,1),sheet.cells(rowsNum+1,3)).Borders.LineStyle = "2"  
  
      '增加Sheet  
      BOOK.Sheets.Add , BOOK.Sheets(BOOK.Sheets.count)  
      BOOK.Sheets(rowsNum+1).Name = tab.code   
  
      Dim shtn  
      Set shtn = EXCEL.workbooks(1).sheets(tab.code)  
      '设置列宽和换行  
       shtn.Columns(1).ColumnWidth = 30     
       shtn.Columns(2).ColumnWidth = 20     
       shtn.Columns(3).ColumnWidth = 20  
       shtn.Columns(5).ColumnWidth = 30     
       shtn.Columns(6).ColumnWidth = 20     
  
       shtn.Columns(1).WrapText =true   
       shtn.Columns(2).WrapText =true   
       shtn.Columns(3).WrapText =true  
       shtn.Columns(5).WrapText =true   
       shtn.Columns(6).WrapText =true  
  
       '设置列标题  
       shtn.cells(1, 1) = "字段中文名"   
       shtn.cells(1, 2) = "字段名"  
       shtn.cells(1, 3) = "字段类型"  
       shtn.cells(1, 5) = tab.code  
       shtn.cells(1, 6) = tab.Name  
       '设置边框   
       shtn.Range(shtn.cells(1, 1),shtn.cells(1, 3)).Borders.LineStyle = "1"  
       shtn.Range(shtn.cells(1, 5),shtn.cells(1, 6)).Borders.LineStyle = "1"  
       '设置背景颜色  
       shtn.Range(shtn.cells(1, 1),shtn.cells(1, 3)).Interior.ColorIndex = "19"  
       shtn.Range(shtn.cells(1, 5),shtn.cells(1, 6)).Interior.ColorIndex = "19"  
  
      Dim col ' running column   
      Dim colsNum  
      Dim rNum   
      colsNum = 0  
      rNum = 0   
            for each col in tab.columns   
              rNum = rNum + 1   
              colsNum = colsNum + 1   
  
            shtn.cells(rNum+1, 1) = col.name   
            shtn.cells(rNum+1, 2) = col.code   
            shtn.cells(rNum+1, 3) = col.datatype   
            next   
            shtn.Range(shtn.cells(rNum-colsNum+2,1),shtn.cells(rNum+1,3)).Borders.LineStyle = "2"           
            rNum = rNum + 1   
  
            Output "FullDescription: "       + tab.Name  
  
   End If     
End Sub