powerdesigner的domains用来规范常用字段的设计挺好，但是我需要把domains在开发团队中共享却发现并没有导入导出功能，我希望能在不同的PDM中方便地导入导出，并且，当导出成excel后，还可以更好的维护（增删改），搜索了百度并没有发现类似的工具或脚本，所以只好参照脚本示例自己改了，测试成功！
导出脚本：
    '******************************************************************************
'* File: Export_Domains_to_excel.vbs
'* Purpose: Scan PDM Model and display domains information
' Export domains to Excel
'* Title:
'* Category:
'* Version: 1.0
'* Company: SF Inc.
'******************************************************************************

Option Explicit

Dim nb
'
' get the current active model
'
Dim mdl ' the current model
Set mdl = ActiveModel
If (mdl Is Nothing) Then
MsgBox "There is no Active Model"
End If
Dim fldr
Set Fldr = ActiveDiagram.Parent
nb =2
Dim HaveExcel
'Dim RQ
'RQ = MsgBox ("Is Excel Installed on your machine ?", vbYesNo + vbInformation,"Confirmation")
'if RQ= VbYes then
HaveExcel= True
' Open & Create Excel Document
Dim x1 '
Set x1 = CreateObject("Excel.Application")
x1.Visible = True
x1.Workbooks.Add
x1.Range("A1").Value = "Class Name"
x1.Range("B1").Value = "Object Name"
x1.Range("C1").Value = "date type"
x1.Range("D1").Value = "date length"
x1.Range("E1").Value = "precision"
x1.Range("F1").Value = "mandatory"
x1.Range("G1").Value = "default"
x1.Range("H1").Value = "comment"

'else
' HaveExcel= false
'end if

ListObjects(fldr)
if HaveExcel= True Then '
x1.Columns("A:D").EntireColumn.AutoFit 'To adjust the
'column's width.
end if

Sub ListObjects(fldr)
Dim obj ' running object
For Each obj In fldr.domains
DescribeObject obj
Next

' go into the sub-packages
Dim f ' running folder
For Each f In fldr.Packages
ListObjects f
Next
End Sub

Sub DescribeObject(CurrentObject)
if CurrentObject.ClassName ="Association-Class link" then exit sub
'Export informations to the output list
output "Found "+CurrentObject.ClassName+" "+CurrentObject.Name+", Created by "+CurrentObject.Creator+" On "+mid(Cstr(CurrentObject.CreationDate),1,10)
if HaveExcel= True Then 'Export informations to Excel document
x1.Range("A"+Cstr(nb)).Value = CurrentObject.ClassName
x1.Range("B"+Cstr(nb)).Value = CurrentObject.Name
x1.Range("C"+Cstr(nb)).Value = CurrentObject.DataType
x1.Range("D"+Cstr(nb)).Value = CurrentObject.length
x1.Range("E"+Cstr(nb)).Value = CurrentObject.Precision
x1.Range("F"+Cstr(nb)).Value = CurrentObject.mandatory
x1.Range("G"+Cstr(nb)).Value = CurrentObject.DefaultValueDisplayed
x1.Range("H"+Cstr(nb)).Value = CurrentObject.comment
nb = nb+1
end if
End Sub

导入domains脚本：
'******************************************************************************
'* File: Export_Domains_to_excel.vbs
'* Purpose: Export domains to Excel
'* Title:
'* Category:
'* Version: 1.0
'* Company: SF Inc.
'******************************************************************************

Option Explicit

Dim nb
'
' get the current active model
'
Dim mdl ' the current model
Set mdl = ActiveModel
If (mdl Is Nothing) Then
MsgBox "There is no Active Model"
End If
Dim fldr
Set Fldr = ActiveDiagram.Parent
nb =2
Dim HaveExcel

HaveExcel= True
' Open & Create Excel Document
Dim x1 '
Set x1 = CreateObject("Excel.Application")
'x1.Visible = True
'对文件的格式是有要求的，可以先导出一个作为模板
x1.Workbooks.open("f:\domains.xlsx")

dim r,i,c,d
r=x1.activeSheet.usedRange.Rows.count
'从第二行读起,第一行标题
for i=2 to r
set d=fldr.domains.createNew
If not d is Nothing then
' Log message in the output
output " add domain: " + d.Name
' Initialize domain object attributes
d.Name =x1.activeSheet.cells(i,2).value
d.Code =x1.activeSheet.cells(i,2).value
d.DataType =x1.activeSheet.cells(i,3).value
'长度与精度统一由datatype字段设置
d.mandatory=x1.activeSheet.cells(i,6).value
d.DefaultValue=x1.activeSheet.cells(i,7).value
d.comment =x1.activeSheet.cells(i,8).value
End If
next
x1.quit
set x1=nothing

操作注意：导入对格式是有要求的，如果不调代码的话，就最好先导出一个excel作为模板，按格式增加其他domain，删除重复的,然后再导入；
enjoy!^_^

ITPub博客

powerdesigner的domains导出与导入脚本

最新文章