PDM与Excel利用VB脚本进行互导

1、基础样例表和数据

Excel数据表，样例中有两个sheet。样表及数据如下：

sheet1=>

sheet2=>

截图=>

2、Excel导入到PDM的脚本

Import_PDM_From_Excel.vbs

'******************************************************************************
'* Purpose:  从Excel中读取信息创建PDM模型
'* Title:
'* Category: 创建
'* Author:   nisj
'* Created:  2015年7月31日
'* Modified:
'* Use:      打开PDM，创建新的PDM，运行本脚本（Ctrl+Shift+X）
'*           Excel 格式要求
'*           MODEL Sheet
'*           |A     |B          |C          |D          |E      |F          |G          |H        |I    |J        |K      |
'*           主题域 |表注释 |表英文名称 |表中文名称 |列名   |列中文名称 |列注释 |数据类型 |主键 |是否为空 |默认值 |
'* Version:  1.0
'* Comment:
'******************************************************************************

Option Explicit

' Model sheet中的列信息
CONST CELL_A="A" '主题域(Pachage)
CONST CELL_B="B" '表注释
CONST CELL_C="C" '表英文名称
CONST CELL_D="D" '表中文名称
CONST CELL_E="E" '列名
CONST CELL_F="F" '列中文名称
CONST CELL_G="G" '列注释
CONST CELL_H="H" '数据类型
CONST CELL_I="I" '是否主键
CONST CELL_J="J" '是否可空
CONST CELL_K="K" '默认值

CONST str_iskey="Y"
'表的所属者
CONST str_username="srv"
CONST isclear_columns = true  '是否先删除表的所有列，如果是false则不会删除excel中没有的列，如果是true，则会重新创建相应表的所有列

' get the current active model
DIM mdl ' 定义当前的模型
SET mdl = ActiveModel '通过全局参数获得当前的模型

IF (mdl IS NOTHING) THEN
   MsgBox "没有选择模型，请选择一个模型并打开"
ELSEIF NOT mdl.IsKindOf(PdPDM.cls_Model) THEN
   MsgBox "当前选择的不是一个物理模型（PDM）."
ELSE

'选择需要导入的Excel文件
' 打开Excel
DIM xlApp   '定义Excel对象
SET xlApp  = CreateObject("Excel.Application")
xlApp.DisplayAlerts = FALSE
DIM xlBook  '定义Excel Sheet
SET xlBook = xlApp.WorkBooks.Open("F:\model\model_import.xlsx")
xlApp.Visible = TRUE

output "开始从Excel创建模型"
Create_From_Excel(xlBook)
output "模型创建完成，开始关闭Excel"

SET xlBook=NOTHING
xlApp.Quit
SET xlApp=NOTHING

END IF

PRIVATE SUB Create_From_Excel(xlBook)
  DIM xlsheet
  DIM rowcount
  dim pkg

  FOR EACH xlsheet IN xlBook.WORKSHEETS
	rowcount = xlsheet.UsedRange.Cells.Rows.Count
	output "本Excel["+xlsheet.name+"]共有行数为:"+CSTR(rowcount)
	IF rowcount>1 THEN
	  SET pkg = CreateOrReplacePackageByName( xlsheet.name , mdl)
	  Create_Model_From_Excel xlsheet,pkg
	  SET xlsheet=NOTHING
	END IF
  NEXT
END SUB

'--------------------------------------------------------------------------------
'功能函数
'--------------------------------------------------------------------------------
PRIVATE SUB Create_Model_From_Excel(xlsheet,package)
	DIM Tab '定义数据表对象
	DIM col
	DIM tabcode
	DIM tabcode1
	DIM i
	DIM col_code

	FOR i=2 TO xlsheet.UsedRange.Cells.Rows.Count
		'判断是否需要创建新表对象
		tabcode1 = xlsheet.Range(CELL_C+CSTR(i)).Value
		IF tabcode1<>"" and tabcode<>tabcode1 THEN
			SET Tab=NOTHING
			tabcode=tabcode1
			IF tabcode<>"" THEN
			    '判断表是否存在，如果不存在则创建，存在则直接返回表对象
				SET tab = CreateOrReplaceTableByCode(tabcode,package)
				'将表的所有列删除,如果需要重新创建表的列
				IF isclear_columns THEN
					DeleteTableColumns(tab)
				END IF
				'更新表的属性
				Tab.code=xlsheet.Range(CELL_C+CSTR(i)).Value
				Tab.name=xlsheet.Range(CELL_D+CSTR(i)).Value
				Tab.comment=xlsheet.Range(CELL_D+CSTR(i)).Value
				Tab.Description=xlsheet.Range(CELL_B+CSTR(i)).Value '注释
				'Tab.owner=FindUserByName(str_username)
				output "创建表模型OK:"+Tab.code+"——"+Tab.name
			END IF
		END IF

		IF NOT(Tab IS NOTHING) THEN '创建表的列
			col_code=xlsheet.Range(CELL_E+CSTR(i)).Value '列代码
			'判断是否已经存在列,不存在则创建
			SET col = CreateOrReplaceColumnByCode(col_code,Tab)
			'设置列属性
			col.code=xlsheet.Range(CELL_E+CSTR(i)).Value '列代码
			col.name=xlsheet.Range(CELL_F+CSTR(i)).Value '列名称
			col.comment=xlsheet.Range(CELL_F+CSTR(i)).Value '列注释
			col.Description=xlsheet.Range(CELL_G+CSTR(i)).Value '列注释
			col.DataType=xlsheet.Range(CELL_H+CSTR(i)).Value '列数据类型
			'列是否主键，如果是主键，则输出 Y
			IF CSTR(xlsheet.Range(CELL_I+CSTR(i)).Value)=str_iskey THEN
				col.primary= TRUE
			END IF
			output "更新表模型的列OK:"+Tab.code+"——"+col.code+"--"+col.name
		END IF
	NEXT

END SUB

'--------------------------------------------------------------------------------
'功能函数
'--------------------------------------------------------------------------------
PRIVATE FUNCTION CreateOrReplacePackageByName(name,model)
	DIM pkg 'Table 对象
	SET pkg = FindPackageByName(name,model)
	IF pkg IS NOTHING THEN
	  SET pkg = model.Packages.CreateNew()
	  pkg.SetNameAndCode name, name
	  pkg.PhysicalDiagrams.Item(0).SetNameAndCode name, name
	END IF
	SET CreateOrReplacePackageByName = pkg
END FUNCTION

PRIVATE FUNCTION CreateOrReplaceTableByCode(code,package)
	DIM tab 'Table 对象
	SET tab = FindTableByCode(code,package)
	IF tab IS NOTHING THEN
	  SET tab = package.Tables.CreateNew()
	  tab.SetNameAndCode code, code
	END IF
	SET CreateOrReplaceTableByCode = tab
END FUNCTION

PRIVATE FUNCTION CreateOrReplaceColumnByCode(code,table)
	DIM col 'Table 对象
	SET col =FindColumnByCode(code,table)
	IF col IS NOTHING THEN
	  SET col =table.Columns.CreateNew
	  col.SetNameAndCode code , code
	END IF
	SET CreateOrReplaceColumnByCode = col
END FUNCTION

PRIVATE FUNCTION FindPackageByName(name,model)
	DIM pkg 'Table 对象
	SET FindPackageByName = NOTHING
	FOR EACH pkg IN model.Packages
		IF NOT pkg.isShortcut THEN
			IF pkg.name =name THEN
				SET FindPackageByName=pkg
				Exit FOR
			END IF
		END IF
	NEXT

END FUNCTION

PRIVATE FUNCTION FindTableByName(name,package)
	DIM Tab1 'Table 对象
	SET FindTableByName = NOTHING
	FOR EACH Tab1 IN package.Tables
		IF NOT Tab1.isShortcut THEN
			IF Tab1.name =name THEN
				SET FindTableByName=Tab1
				Exit FOR
			END IF
		END IF
	NEXT
END FUNCTION

PRIVATE FUNCTION FindTableByCode(code,package)
	DIM Tab1 'Table 对象
	SET FindTableByCode = NOTHING
	FOR EACH Tab1 IN package.Tables
		IF NOT Tab1.isShortcut THEN
			'OUTPUT "循环表:"+Tab1.name
			IF Tab1.code =code THEN
				SET FindTableByCode=Tab1
				Exit FOR
			END IF
		END IF
	NEXT
END FUNCTION

PRIVATE FUNCTION FindColumnByCode(code,tabobj)
	DIM col1 'Column 对象
	'OUTPUT "code:"+code
	SET FindColumnByCode = NOTHING
	FOR EACH col1 IN tabobj.Columns
		'OUTPUT "code2:"+col1.code
		IF col1.code =code THEN
			SET FindColumnByCode=col1
			EXIT FOR
		END IF
	NEXT
END FUNCTION

PRIVATE FUNCTION FindColumnByName(name,tabobj)
	DIM col1 'Column 对象
	'OUTPUT "codename:"+name
	SET FindColumnByName = NOTHING
	FOR EACH col1 IN tabobj.Columns
		IF col1.name =name THEN
			SET FindColumnByName=col1
			EXIT FOR
		END IF
	NEXT
END FUNCTION

PRIVATE FUNCTION FindDomainByName(dmname,mdl)

	DIM dm1 'Domain 对象
	SET FindDomainByName = NOTHING

	FOR EACH dm1 IN mdl.domains
		IF NOT dm1.isShortcut THEN
			IF dm1.name =dmname THEN
				SET FindDomainByName =dm1
				EXIT FOR
			END IF
		END IF
	NEXT

END FUNCTION

PRIVATE FUNCTION FindUserByName(username)
	DIM user1
	SET FindUserByName = NOTHING
	FOR EACH user1 IN mdl.users
		IF user1.name=username THEN
			SET FindUserByName=user1
			EXIT FOR
		END IF
	NEXT

END FUNCTION

' 删除表的所有列
PRIVATE SUB DeleteTableColumns(table)
  IF NOT table.isShortcut THEN
   DIM col
   FOR EACH col IN table.columns
  	'output "Column deleted :"+table.name
  	col.Delete
  	SET col = NOTHING
   NEXT
  END IF
END SUB

3、PDM导出成EXCEL的脚本

Export_PDM_To_Excel.vbs

'******************************************************************************
'* File:     Export_model_to_excel.vbs
'* Purpose:  将模型Table等对象的描述信息导出到Excel中
'* Title:
'* Category: Export
'* Author:   nisj
'* Created:  2015年7月31日
'* Modified:
'* Use:      打开PDM，创建新的PDM，运行本脚本（Ctrl+Shift+X）
'*           Excel 格式为
'*           MODEL Sheet
'*           |A     |B          |C          |D          |E      |F          |G          |H        |I    |J        |K      |
'*           主题域 |表注释 |表英文名称 |表中文名称 |列名   |列中文名称 |列注释 |数据类型 |主键 |是否为空 |默认值 |
'* Version:  1.0
'* Comment:
'******************************************************************************
Option Explicit

' Model sheet中的列信息
CONST CELL_A="A" '主题域(Pachage)
CONST CELL_B="B" '表注释
CONST CELL_C="C" '表英文名称
CONST CELL_D="D" '表中文名称
CONST CELL_E="E" '列名
CONST CELL_F="F" '列中文名称
CONST CELL_G="G" '列注释
CONST CELL_H="H" '数据类型
CONST CELL_I="I" '是否主键
CONST CELL_J="J" '是否可空
CONST CELL_K="K" '默认值

CONST str_iskey="Y"

DIM nb
'
' get the current active model
'
DIM mdl ' the current model
SET mdl = ActiveModel
IF (mdl IS NOTHING) THEN
   MsgBox "没有选择一个Model"
END IF

DIM fldr
SET Fldr = ActiveDiagram.Parent

DIM isMerage '是否需要合并表名称单元格
DIM isMulite '是否不同的Package不同的sheet
DIM RQ

RQ = MsgBox ("是否不同的Package不同的sheet?", vbYesNo + vbInformation,"确认")
IF RQ= VbYes THEN
 isMulite= TRUE
ELSE
 isMulite= FALSE
END IF

' 创建新的Excel
DIM x1  '
SET x1 = CreateObject("Excel.Application")
x1.Workbooks.Add
x1.Visible = TRUE

ExportModelToExcel( fldr)

MsgBox "成功将 Models 导出到Excel中！"

'--------------------------------------------------------------------------------
'功能函数:将模型导出到Sheet页【 MODEL 】
'--------------------------------------------------------------------------------
PRIVATE FUNCTION ExportModelToExcel(folder)
    '如果是每个package导出到不同的sheet页面，则采用folder的名称作为sheet页名称，否则使用"MODEL"作为sheet页名称
  IF isMulite THEN
    IF folder.Tables.count>0 THEN
	  AddExcelSheet(folder.name)
    END IF
  ELSE
    AddExcelSheet("MODEL")
  END IF
  '写sheet页的第一行表头
  WriteExcelModelHead

  DIM nStart
  DIM nEnd

  DIM tabobj '定义数据表对象

  nb=2
  isMerage=TRUE
  '开始循环处理所有的folder
  FOR EACH tabobj IN folder.Tables
    IF NOT tabobj.isShortcut THEN '快捷方式不处理
	  '合并表的单元格A、B、C
      IF isMerage THEN  '合并表的单元格A、B、C
        nStart=nb '合并起始行
        nEnd=nb+tabobj.Columns.count-1 '合并结束行
		IF nStart<>nEnd THEN
          '合并单元格
          x1.Range(CELL_A+CSTR(nStart)+":"+CELL_A+CSTR(nEnd)).SELECT
          x1.Selection.Merge
          x1.Range(CELL_B+CSTR(nStart)+":"+CELL_B+CSTR(nEnd)).SELECT
          x1.Selection.Merge
		END IF

        '将主题域、表名称、表注释填写到合并后单元格中
        x1.Range(CELL_A+CSTR(nb)).Value = folder.name   '主题域
        x1.Range(CELL_B+CSTR(nb)).Value = Rtf2Ascii(tabobj.description)   '表注释
      END IF

      '开始循环列兵输出信息
      DIM colobj '定义列对象
      FOR EACH colobj IN tabobj.Columns
		'写表的信息
        x1.Range(CELL_C+CSTR(nb)).Value = tabobj.code    '表英文名称
        x1.Range(CELL_D+CSTR(nb)).Value = tabobj.name    '表英文名称

        '写列的信息
        x1.Range(CELL_E+CSTR(nb)).Value = colobj.code    '列名
        x1.Range(CELL_F+CSTR(nb)).Value = colobj.name    '列中文名称
		x1.Range(CELL_G+CSTR(nb)).Value = Rtf2Ascii(colobj.Description) '列注释
        x1.Range(CELL_H+CSTR(nb)).Value = colobj.DataType    '数据类型
        '列是否主键，如果是主键，则输出 Y
        IF colobj.primary THEN
          x1.Range(CELL_I+CSTR(nb)).Value = "Y"
        END IF

        nb = nb+1  '行号加1
      NEXT
    END IF
  NEXT

  '对子包进行递归，如果不使用递归只能取到第一个模型图内的表
  DIM subfolder
  FOR EACH subfolder IN folder.Packages
    ExportModelToExcel(subfolder)
  NEXT

END FUNCTION

'--------------------------------------------------------------------------------
'功能函数:添加一个Sheet页
'--------------------------------------------------------------------------------
PRIVATE SUB AddExcelSheet(sheetname)
  x1.Sheets.Add
  x1.ActiveSheet.Name=sheetname
END SUB

'--------------------------------------------------------------------------------
'功能函数:写Excel的第一行信息
'--------------------------------------------------------------------------------
PRIVATE SUB WriteExcelModelHead()
   x1.Range(CELL_A+"1").Value = "主题域"
   x1.Range(CELL_B+"1").Value = "表注释"
   x1.Range(CELL_C+"1").Value = "表英文名称"
   x1.Range(CELL_D+"1").Value = "表中文名称"
   x1.Range(CELL_E+"1").Value = "列名"
   x1.Range(CELL_F+"1").Value = "列中文名称"
   x1.Range(CELL_G+"1").Value = "列注释"
   x1.Range(CELL_H+"1").Value = "数据类型"
   x1.Range(CELL_I+"1").Value = "主键"
   x1.Range(CELL_J+"1").Value = "是否为空"
   x1.Range(CELL_K+"1").Value = "默认值"

   '设置字体
   x1.Columns(CELL_A+":"+CELL_K).SELECT
   WITH x1.Selection.Font
        .Name = "宋体"
        .Size = 10
   END WITH

   '设置首行可过滤,背景颜色为灰色,字体粗体
   x1.Range(CELL_A+"1:"+CELL_K+"1").SELECT
   x1.Selection.AutoFilter
   x1.Selection.Interior.ColorIndex = 15
   x1.Selection.Font.Bold = TRUE
   '设定首行固定
   x1.Range(CELL_A+"2").SELECT
   x1.ActiveWindow.FreezePanes = TRUE

END SUB

4、Excel直接生成建库脚本的VB

在Excel中，主要通过如下的菜单找到写宏执行宏的地方：

文件-->选项-->自定义功能区-->自定义功能区（主选项卡）-->勾选"开发工具"；然后到开发工具主菜单中，开发工具-->宏-->进行新建和执行。

From_Excel_model_generate_sql.txt

Sub create_all_sheet_sql()
Dim xlsheet

For Each xlsheet In ThisWorkbook.Worksheets
    Create_SQL xlsheet.Name, "F:\model\"
Next

End Sub
Sub Create_SQL(sheetName, outputPath)

Dim strPath As String
Dim RowCount As Integer
Dim xlsheet_src
Dim strSQL As String
Dim hasCreat As Integer

Dim strTable1 As String
Dim strTable As String
Dim strTableComm As String
Dim strField As String
Dim strFieldComm As String
Dim strType As String
Dim strKey As String

' 请根据实际情况修改下面3个值
'sheetName = "1-核心表"  '要生成SQL的Sheet页的名称
strPath = outputPath + sheetName + ".sql" '"d:\2001.sql"    '生成的SQL文件

Set xlsheet_src = ThisWorkbook.Worksheets(sheetName)
RowCount = xlsheet_src.UsedRange.Cells.Rows.Count '得到此Sheet的行数
hasCreat = 0

'生成表的建表语句
For i = 2 To RowCount + 1

    strTable1 = xlsheet_src.Range("C" + CStr(i)).Value

    If strTable <> strTable1 Then
        If hasCreat = 1 Then
            strSQL = ");"
            ret = sWriteFile(strSQL, strPath)
            strSQL = ""
            hasCreat = 0
        End If

        strTable = strTable1
        If (strTable <> "") Then
            strTableComm = xlsheet_src.Range("D" + CStr(i)).Value
            strSQL = "DROP TABLE " & strTable & ";" & vbCrLf & "CREATE TABLE " & strTable & "( " & " -- " & strTableComm
            ret = sWriteFile("", strPath)
            ret = sWriteFile(strSQL, strPath)
            intRow = 1
            hasCreat = 1
        End If
    End If

    If strTable <> "" Then
        strField = xlsheet_src.Range("E" + CStr(i)).Value
        strFieldComm = xlsheet_src.Range("F" + CStr(i)).Value
        strType = xlsheet_src.Range("H" + CStr(i)).Value
        If strField <> "" Then
            If intRow = 1 Then
                strSQL = "    " & strField & " " & strType & " -- " & strFieldComm
            Else
                strSQL = "   ," & strField & " " & strType & " -- " & strFieldComm
            End If
            ret = sWriteFile(strSQL, strPath)
            intRow = intRow + 1
        End If
    End If

Next

'生成表的comment语句
For i = 2 To RowCount

    strTable1 = xlsheet_src.Range("C" + CStr(i)).Value
    If strTable1 <> "" Then
        If strTable <> strTable1 Then
            strTable = strTable1
            strTableComm = xlsheet_src.Range("D" + CStr(i)).Value
            strSQL = "comment on table " & strTable & " is '" & strTableComm & "';"
            ret = sWriteFile("", strPath)
            ret = sWriteFile(strSQL, strPath)
            intRow = 1
            hasCreat = 1
        End If
    End If

    If strTable <> "" Then

        strField = xlsheet_src.Range("E" + CStr(i)).Value
        strFieldComm = xlsheet_src.Range("F" + CStr(i)).Value
        strType = xlsheet_src.Range("H" + CStr(i)).Value
        If strField <> "" Then
            strSQL = "comment on column " & strTable & "." & strField & " is '" & strFieldComm & "';"
            ret = sWriteFile(strSQL, strPath)
            intRow = intRow + 1
        End If

    End If

Next

End Sub

Function sWriteFile(strSQL As String, strFullFileName As String)
    Dim intFileNum As String
    intFileNum = FreeFile
    Open strFullFileName For Append As #intFileNum
    Print #intFileNum, strSQL
    Close #intFileNum
End Function

版权声明：本文为博主原创文章，未经博主允许不得转载。