Speeding up access to PD-Objects

[former_member185199]

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