PDM與Excel利用VB腳本進行互導

1、基礎樣例表和數據

Excel數據表，樣例中有兩個sheet。樣表及數據如下：

 sheet1=>

主題域	表註釋	表英文名稱	表中文名稱	列名	列中文名稱	列註釋	數據類型	主鍵	是否爲空	默認值
協議		order_info	訂單信息表	STATIS_DATE	統計時間		varchar2(100)
		order_info	訂單信息表	ORDR_GUID	訂單GUID		varchar2(101)	Y
		order_info	訂單信息表	CO_CD	公司代碼		varchar2(102)
		order_info	訂單信息表	CO_NAME	公司名稱		varchar2(103)
		order_info	訂單信息表	SERV_ORDR_NO	服務訂單號		varchar2(104)
		order_info	訂單信息表	OMS_ORDR_NO	OMS行訂單號		varchar2(105)
		order_info	訂單信息表	ORDR_TYPE	訂單類型		varchar2(106)
		order_info	訂單信息表	SERV_ORG	服務組織		varchar2(107)
		order_info	訂單信息表	QA_FLG	質保標識		varchar2(108)
協議		personnel	人員信息表	STATIS_DATE	統計時間		VARCHAR(14)
		personnel	人員信息表	CLIENT	客戶端		VARCHAR(9)	Y
		personnel	人員信息表	PARTNER	業務合作伙伴標識		VARCHAR(30)
		personnel	人員信息表	BEGDA	開始日期		VARCHAR(14))
		personnel	人員信息表	ENDDA	結束日期		VARCHAR(14))
		personnel	人員信息表	BUKRS	公司代碼		VARCHAR(12)

sheet2=>

主題域	表註釋	表英文名稱	表中文名稱	列名	列中文名稱	列註釋	數據類型	主鍵	是否爲空	默認值
交易		deal_hurry	交易流水錶	STATIS_DATE	統計時間		date
		deal_hurry	交易流水錶	ORDR_GUID	訂單GUID		varchar2(101)	Y
		deal_hurry	交易流水錶	CO_CD	公司代碼		int		Y	1000
		deal_hurry	交易流水錶	CO_NAME	公司名稱		varchar2(103)
		deal_hurry	交易流水錶	SERV_ORDR_NO	服務訂單號		varchar2(104)
		deal_hurry	交易流水錶	OMS_ORDR_NO	OMS行訂單號		number(22,3)
		deal_hurry	交易流水錶	ORDR_TYPE	訂單類型		varchar2(106)
		deal_hurry	交易流水錶	SERV_ORG	服務組織		varchar2(107)
		deal_hurry	交易流水錶	QA_FLG	質保標識		varchar2(108)
交易		person	人員表	STATIS_DATE	統計時間		date
		person	人員表	CLIENT	客戶端		VARCHAR(9)	Y
		person	人員表	PARTNER	業務合作伙伴標識		VARCHAR(30)
		person	人員表	BEGDA	開始日期		date		Y
		person	人員表	ENDDA	結束日期		date		Y
		person	人員表	BUKRS	公司代碼		int

截圖=>

 

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