利用VBA从Excel导入数据模型到PowerDesigner

导入的Excel格式和上一篇博文里从PowerDesigner导出到Excel的格式相同，代码如下：

Option Explicit
'-------------------------------------------------------------------------------
'作用：Excel导入到PowerDesigner
'
'作者: Lio5n
'
'日期: 20151217
'
'版本: V1.0
'
'说明：暂无法设置Owner和分布键
'-------------------------------------------------------------------------------

'----------------------------------请按需设置-----------------------------------
CONST INPUT_FILE  = "D:File_Name.xlsm"        '导入文件路径
CONST LOG_FILE  = "D:pd_2_excel.log"          '日志文件路径
'----------------------------------目录页设置-----------------------------------
CONST COL_TABLE_SCHEMA          = "B"           '表模式列（Owner）
CONST COL_TABLE_CODE            = "C"           '表英文名列
CONST COL_TABLE_NAME            = "D"           '表中文名列
CONST COL_DEAL_FLAG             = "E"           '处理标志列
CONST COL_TABLE_COMMENT         = "F"           '表说明列（Comment）
'----------------------------------内容页设置-----------------------------------
CONST COL_COL_NAME              = "B"           '字段中文名
CONST COL_COL_CODE              = "C"           '字段英文名
CONST COL_COL_DATATYPE          = "D"           '字段类型
CONST COL_COL_PRIMARY           = "F"           '主键
CONST COL_COL_MANDATORY         = "G"           '非空
CONST COL_COL_DISTRIBUTIONKEYS  = "H"           '分布键
CONST COL_COL_COMMENT           = "I"           '说明（Comment）
'-------------------------------------------------------------------------------
CONST BEG_ROW = 6                               '数据区域-开始行
CONST MAX_TABLES       = 1000                   '表数量上限
CONST MAX_COLUMNS      = 1000                   '单表字段数量上限
CONST PHYSICAL_OPTIONS = "WITH(APPENDONLY=TRUE,COMPRESSLEVEL=6,ORIENTATION=COLUMN,COMPRESSTYPE=ZLIB)"

Dim mCR,mLF
mCR = Chr(10)       '换行
mLF = Chr(13)       '回车
'-------------------------------------------------------------------------------

'定义PDM
Dim mdl
Dim errCount, errString, errMsg
errMsg=""
errCount=0
Set mdl = ActiveModel
If ( mdl Is Nothing ) Then
    MsgBox "There is no Active Model"
Else
    importTables mdl
    If errCount > 0 Then
        output "错误信息: " + errMsg
    End If
    MsgBox "处理完毕,共有"+Cstr(errCount)+"个错误!"
    If Trim(errMsg)<>"" Then
        MsgBox errMsg
    End If
End If

'导入表结构
Sub importTables(mdl)

    Dim ExcelApp, ExcelBook, ExcelSheet

    Set ExcelApp = CreateObject("Excel.Application")
    ExcelApp.visible=FALSE
    Set ExcelBook = ExcelApp.Workbooks.Open(INPUT_FILE)

    '-------------------读取目录-------------------
    Dim tblSchema, tblName, tblCode, tblComment
    Dim tblIdx, tblCnt
    tblIdx = 0
    tblCnt = 0
    For tblIdx = 2 To MAX_TABLES+2
        If ExcelBook.Worksheets("目录").Cells(tblIdx, "A").Value = "" Then
            Exit For
        End If

        If UCase(ExcelBook.Worksheets("目录").Cells(tblIdx,COL_DEAL_FLAG).value) = "Y" Then
            tblCnt = tblCnt + 1

            tblSchema    = Trim(ExcelBook.Worksheets("目录").Cells(tblIdx, COL_TABLE_SCHEMA).Value)
            tblCode      = Trim(ExcelBook.Worksheets("目录").Cells(tblIdx, COL_TABLE_CODE).Value)
            tblName      = Trim(ExcelBook.Worksheets("目录").Cells(tblIdx, COL_TABLE_NAME).Value)
            tblComment   = Trim(ExcelBook.Worksheets("目录").Cells(tblIdx, COL_TABLE_COMMENT).Value)
            If Len(tblComment) = 0 Then
                tblComment = tblName
            End If

            '-------------------读取Sheet页-------------------
            On Error Resume Next
            Dim shtIdx
            shtIdx = ExcelBook.Worksheets(tblCode).Index
            If Err.Number <> 0 Then
                output "Table[" + tblCode + "][" + tblName + "] 找不到该Sheet页！"
                errCount  = errCount + 1
                errString = cstr(now) + " <" + cstr(errCount) + "> [文件错误]---[" + tblCode + "][" + tblName + "] 找不到该Sheet页！" + mLF
                        errMsg = errMsg + errString
            Else
                output "[" + tblCode + "][" + tblName + "]"
                ExcelBook.Worksheets(shtIdx).Activate

                '建表
                createTable mdl,ExcelBook,shtIdx,tblName,tblCode,tblComment,tblSchema

            End If
            '-------------------读取Sheet页 END---------------
        End If
    Next
    '-------------------读取目录 END---------------

    ExcelBook.Close
    ExcelApp.Quit
    Set ExcelSheet = Nothing
    Set ExcelBook = Nothing
    Set ExcelApp = Nothing

    output "导入完毕, 共导入 " + Cstr(tblCnt) + " 张表!"
    
    Dim fs, ft
    Set fs = CreateObject("scripting.filesystemobject")
    Set ft = fs.createtextfile(LOG_FILE)
    ft.WriteLine (errMsg)
    ft.Close
    Set ft = Nothing: Set fs = Nothing
    
    
    Exit Sub
End Sub

'建表
Sub createTable(mdl,ExcelBook,shtIdx,tblName,tblCode,tblComment,tblOwner)

    '查找用户
    'Dim tblOwner
    'Set tblOwner = mdl.FindChildByCode(tblSchema,cls_User)
    'If ( tblOwner Is Nothing ) Then
    '    output "未找到用户[" + tblSchema + "]"
    '    errString = errString + mLF + "未找到用户[" + tblSchema + "]"
    '    errCount  = errCount + 1
    'End If

    '检查表是否已经存在
    Dim objTable, col
    set objTable = mdl.FindChildByName(tblName,cls_Table)
    If ( objTable Is Nothing ) Then
    Else
        output "表[" + tblName + "]已经存在！"
        errCount  = errCount + 1
        errString = cstr(now) + " <" + cstr(errCount) + "> [表错误]-----[" + tblName + "] 已经存在！" + mLF
        errMsg = errMsg + errString
        Exit Sub
    End If
    set objTable = mdl.FindChildByCode(tblCode,cls_Table)
    If ( objTable Is Nothing ) Then
    Else
        output "表[" + tblCode + "]已经存在！"
        errCount  = errCount + 1
        errString = cstr(now) + " <" + cstr(errCount) + "> [表错误]-----[" + tblCode + "] 已经存在！" + mLF
        errMsg = errMsg + errString
        Exit Sub
    End If

    '建表
    Set objTable = mdl.Tables.CreateNew
    objTable.Name    = tblName
    objTable.Code    = tblCode
    objTable.Comment = tblComment
    'objTable.Owner   = tblOwner
    objTable.PhysicalOptions = PHYSICAL_OPTIONS

    '解析字段
    Dim colIdx, colCnt
    colCnt = 0
    For colIdx = BEG_ROW To MAX_COLUMNS+BEG_ROW
        If ExcelBook.Worksheets(shtIdx).Cells(colIdx, "A").Value = "" Then
            Exit For
        End If

        Dim colName, colCode, colDataType, colComment, colMandatory, colPrimary, colDistributionKeys
        colName      = Trim(CStr(ExcelBook.Worksheets(shtIdx).Cells(colIdx, COL_COL_NAME).Value))       '字段中文名
        colCode      = Trim(CStr(ExcelBook.Worksheets(shtIdx).Cells(colIdx, COL_COL_CODE).Value))       '字段英文名
        colDataType  = Trim(CStr(ExcelBook.Worksheets(shtIdx).Cells(colIdx, COL_COL_DATATYPE).Value))   '字段字段类型
        colPrimary   = Trim(CStr(ExcelBook.Worksheets(shtIdx).Cells(colIdx, COL_COL_PRIMARY).Value))    '主键
        colMandatory = Trim(CStr(ExcelBook.Worksheets(shtIdx).Cells(colIdx, COL_COL_MANDATORY).Value))  '非空
        'colDistributionKeys =                                                                          '分布键
        colComment   = Trim(CStr(ExcelBook.Worksheets(shtIdx).Cells(colIdx, COL_COL_COMMENT).Value))    '说明
        If Len(colComment) = 0 Then
            colComment = colName
        End If

        '建字段
        With ExcelBook
            Set col = objTable.Columns.CreateNew
            
            '检查表是否已经存在
                Dim objColumn
                    set objColumn = objTable.FindChildByName(colName,cls_Column)
                    If ( objColumn Is Nothing ) Then
                    Else
                        output "字段[" + colName + "]已经存在！"
                        errCount  = errCount + 1
                        errString = cstr(now) + " <" + cstr(errCount) + "> [字段错误]---[" + objTable.Name + "." + colName + "] 已经存在！" + mLF
                        errMsg = errMsg + errString
                        
                        Exit Sub
                    End If        
                    set objColumn = objTable.FindChildByCode(colCode,cls_Column)
                    If ( objColumn Is Nothing ) Then
                    Else
                        output "字段[" + colCode + "]已经存在！"
                        errCount  = errCount + 1
                        errString = cstr(now) + " <" + cstr(errCount) + "> [字段错误]---[" + objTable.Name + "." + colCode + "] 已经存在！" + mLF
                        errMsg = errMsg + errString
                        Exit Sub
                    End If        
            
            col.Name = colName
            col.Code = UCase(colCode)
            col.DataType = UCase(colDataType)
            col.Comment = colComment
            If UCase(colMandatory) = "Y" Or UCase(colMandatory) = "YES" Then
                col.Mandatory = true                '指定列是否可空 true 为不可空
            End If
            If UCase(colPrimary) = "Y" Or UCase(colPrimary) = "YES" Then
                col.Primary = true                  '指定主键
            End If
        End With
        colCnt = colCnt + 1

    Next

    '设置分布键
    'If Len(colDistributionKeys) > 0 Then
    '    objTable.PhysicalOptions = objTable.PhysicalOptions + mLF + "distributed by (" + colDistributeKeys + ")"
    'End If

End Sub