most of the PD-Objectmodel consists of ObjectBag wich are not really powerful when it comes to search objects.
Here is some Example Code how you can speed up the search of objects of an EAM using Dictionaries:
Some of the objects used are extended objects so they need special treatment, i also packed it in a class (YES vbs is object oriented, even when most code doesn´t look like)
Dont hesitate to ask questions or comment
'
' Code zum erzeugen von Dictionaries
'
'
Option Explicit
Class EAMObject
private IMDict ,STDict, PDMDict ,STPDict,DOCDict
private openModels
private inc_EAMObjects_InputModel
Private Sub Class_Initialize()
Set openModels = CreateObject("Scripting.Dictionary")
Set IMDict = CreateObject("Scripting.Dictionary")
Set STDict = CreateObject("Scripting.Dictionary")
Set PDMDict = CreateObject("Scripting.Dictionary")
Set STPDict = CreateObject("Scripting.Dictionary")
Set DOCDict = CreateObject("Scripting.Dictionary")
'//TODO test ob activemodel ein EAM ist
if ActiveModel.ClassKind = cls_EAMModel then
Set inc_EAMObjects_InputModel = ActiveModel
fillIMDict
fillPDMDict
fillSTDict
fillSTPDict
fillDOCDict
debug.write "EAMObject INIT SUCCESSFUL"
else
msgbox "Aktives Model is NO EAM !!!"
WScript.QUIT 666
end if
'call test
End Sub
Private Sub Class_Terminate( )
'Debug.Writeln "Termination code goes here"
Set IMDict = nothing
Set STDict = nothing
Set PDMDict = nothing
Set STPDict = nothing
Set DOCDict = nothing
Set inc_EAMObjects_InputModel = nothing
End Sub
Public Property Set InputModel(modeltoset)
If inc_EAMObjects_InputModel Is Nothing Then
Set IMDict = CreateObject("Scripting.Dictionary")
Set STDict = CreateObject("Scripting.Dictionary")
Set PDMDict = CreateObject("Scripting.Dictionary")
Set STPDict = CreateObject("Scripting.Dictionary")
Set DOCDict = CreateObject("Scripting.Dictionary")
'//TODO test ob activemodel ein EAM ist
if ActiveModel.ClassKind = cls_EAMModel then
Set inc_EAMObjects_InputModel = ActiveModel
fillIMDict
fillPDMDict
fillSTDict
fillSTPDict
fillDOCDict
debug.write "EAMObject INIT SUCCESSFUL"
else
msgbox "Aktives Model is NO EAM !!!"
Err.Raise 666
end if
End If
if not isnull(modeltoset) then
set inc_EAMObjects_InputModel = OpenModel(modeltoset)
Set IMDict = CreateObject("Scripting.Dictionary")
Set STDict = CreateObject("Scripting.Dictionary")
Set PDMDict = CreateObject("Scripting.Dictionary")
Set STPDict = CreateObject("Scripting.Dictionary")
Set DOCDict = CreateObject("Scripting.Dictionary")
'//TODO test ob activemodel ein EAM ist
if ActiveModel.ClassKind = cls_EAMModel then
Set inc_EAMObjects_InputModel = ActiveModel
fillIMDict
fillPDMDict
fillSTDict
fillSTPDict
fillDOCDict
debug.write "EAMObject INIT SUCCESSFUL"
else
msgbox "Aktives Model ist KEIN EAM !!!"
Err.Raise 666
end if
end if
End Property
Public Property Get InputModel()
set InputModel = inc_EAMObjects_InputModel
End Property
function getCollectionByName(obj,colname)
dim ec: For Each ec In obj.ExtendedCollections
If ec.name = colname Then
set getCollectionByName = ec
exit function
end if
next
end function
'--------------------------------------------------------------------
'
' functions to fill and read the Dictionarys
'
'
Sub fillIMDict()
Dim m 'As ExtendedObject
IMDict.CompareMode = vbTextCompare
Dim col
Set col = inc_EAMObjects_InputModel.GetCollectionByStereotype("InformaticaMapping")
For Each m In col
IMDict.Add m.code, m
debug.write "Added " & IMDict.Item(m.code)
Next 'm
End Sub
Sub fillDOCDict()
Dim m 'As ExtendedObject
DOCDict.CompareMode = vbTextCompare
Dim col
Set col = inc_EAMObjects_InputModel.GetCollectionByName("Documents")
For Each m In col
DOCDict.Add UCASE(m.code), m
debug.write "Added " & DOCDict.Item(m.code)
Next 'm
End Sub
Sub fillPDMDict()
Dim m 'As ExtendedObject
PDMDict.CompareMode = vbTextCompare
Dim col
Set col = inc_EAMObjects_InputModel.GetCollectionByStereotype("PDM")
For Each m In col
PDMDict.Add m.GetExtendedAttribute("PDM Name"), m
Debug.Write "Added " & PDMDict.Item(m.GetExtendedAttribute("PDM Name"))
Next 'm
End Sub
Sub fillSTDict()
Dim m 'As ExtendedObject
STDict.CompareMode = vbTextCompare
Dim col
Set col = inc_EAMObjects_InputModel.GetCollectionByStereotype("Sourcetarget")
For Each m In col
'Debug.Writeln "Adding " & m.Code
STDict.Add ucase(m.name), m
'Debug.Writeln "Added " & STDict.Item(m.Name) & STDict.Item(m.Code)
Next 'm
End Sub
Sub fillSTPDict()
Dim m 'As ExtendedObject
STPDict.CompareMode = vbTextCompare
Dim col
Set col = inc_EAMObjects_InputModel.GetCollectionByStereotype("Source/TargetPDM")
For Each m In col
'Debug.Writeln "Adding " & m.Code
STPDict.Add m.Code, m
'Debug.Writeln "Added " & m.Code & " - " & STPDict.Item(m.Code)
Next 'm
End Sub
Function getPDMbyName(PDMName)' As String) As ExtendedObject
'PDMName = UCase(PDMName) ' keys wurden in Grossbuchstaben gewandelt, warum????
If PDMDict.Exists(PDMName) Then
Set getPDMbyName = PDMDict.Item(PDMName)
Exit Function
Else
Set getPDMbyName = getPDMbyName_slow(PDMName)
End If
End Function
Function getPDMbyName_slow(PDMName )'As String) As ExtendedObject
Dim m 'As ExtendedObject
Dim col
Set col = inc_EAMObjects_InputModel.GetCollectionByStereotype("PDM")
For Each m In col
If m.GetExtendedAttribute("PDM Name") = PDMName Then
Set getPDMbyName_slow = m
Exit Function
End If
Next 'm
'Set getPDMbyName_slow = getPDMbyName_slow("UNBEKANNT")
End Function
Function getSTbyName(STName)' As String) As ExtendedObject
STName = UCase(STName) '
If STDict.Exists(STName) Then
Set getSTbyName = STDict.Item(STName)
Exit Function
End If
Set getSTbyName = getSTbyName_slow("STName")
End Function
Function getSTbyName_slow(STName )'As String) As ExtendedObject
Dim m 'As ExtendedObject
Dim col 'As ObjectBag
Set col = inc_EAMObjects_InputModel.GetCollectionByStereotype("Sourcetarget")
For Each m In col
If ucase(m.name) = ucase(STName) Then
Set getSTbyName_slow = m
Exit Function
End If
Next'm
End Function
Function getSTPbyName(STPName)' As String) As ExtendedObject
'STPName = UCase(STPName) ' keys wurden in Grossbuchstaben gewandelt, warum????
If STPDict.Exists(STPName) Then
Set getSTPbyName = STPDict.Item(STPName)
Exit Function
End If
End Function
Function getSTPbyName_slow(STPName)' As String) As ExtendedObject
Dim m 'As ExtendedObject
Dim col 'As ObjectBag
Set col = inc_EAMObjects_InputModel.GetCollectionByStereotype("Sourcetarget")
For Each m In col
If m.name = STPName Then
Set getSTPbyName_slow = m
Exit Function
End If
Next 'm
End Function
Function getIMbyName(IMName)' As String) As ExtendedObject
'IMName = UCase(IMName) ' keys wurden in Grossbuchstaben gewandelt, warum????
If IMDict.Exists(IMName) Then
Set getIMbyName = IMDict.Item(IMName)
Exit Function
Else
Set getIMbyName = getIMbyName_slow(IMName)
End If
End Function
Function getIMbyName_slow(IMName )'As String) As ExtendedObject
Dim m 'As ExtendedObject
Dim col
Set col = inc_EAMObjects_InputModel.GetCollectionByStereotype("InformaticaMapping")
For Each m In col
If m.name = IMName Then
Set getIMbyName_slow = m
Exit Function
End If
Next 'm
Set getIMbyName_slow = getIMbyName_slow("UNBEKANNT")
End Function
Function getDOCbyName(DOCName)' As String) As ExtendedObject
DOCName = UCase(DOCName) ' keys wurden in Grossbuchstaben gewandelt, warum????
If DOCDict.Exists(DOCName) Then
Set getDOCbyName = DOCDict.Item(DOCName)
Exit Function
Else
Set getDOCbyName = getDOCbyName_slow(DOCName)
End If
End Function
Function getDOCbyName_slow(DOCName )'As String) As ExtendedObject
Dim m 'As ExtendedObject
Dim col
Set col = inc_EAMObjects_InputModel.GetCollection("Documents")
For Each m In col
If m.name = DOCName Then
Set getDOCbyName_slow = m
Exit Function
End If
Next 'm
Set getDOCbyName_slow = getDOCbyName_slow("UNBEKANNT")
End Function
end class
