Often times you add new columns to an entity, and you want to add them to multiple other entities, so this script will help speed things up.

also it will benefit in teaching how to make a collection in vbscript.


Option Explicit
Dim mdl ' the current model
Dim fldr
Dim oColect
Dim sSearchEntityFrom
Dim sSearchEntityTo
Dim objSourceEntity
Dim objDestinationEntity
Dim RQ
dim iCountChanged, iCountFields, iCountEntities
dim sCSVFile
Dim obj ' running object
Dim objFound
Set oColect = CreateObject( "Scripting.Dictionary" )
' get the current active model
Set mdl = ActiveModel
call mainProcedure
'-----------------------------------------------------------------------------
' Main function
'-----------------------------------------------------------------------------
sub mainProcedure()
   If (mdl Is Nothing) Then
      MsgBox "There is no Active Model"
      exit sub
   End If
   If Not mdl.IsKindOf(PdCDM.cls_Model) Then
      MsgBox "This is not CDM"
      exit sub
   end if
   Set Fldr = ActiveDiagram.Parent
   RQ = MsgBox ("Starting at Folder: " & Fldr.Name & " Is Run ?", vbYesNo + vbInformation,"Confirmation")
   if RQ= VbNo then
      exit sub
   end if
   iCountChanged=0
   iCountEntities=0
   iCountFields=0
  
   Dim SourceEntity
   Dim DestinationEntity
   SourceEntity="Entity_55" 
  
   getEntity  fldr, SourceEntity 
   Set objSourceEntity = objFound
  
      if objSourceEntity is nothing = true then
         output "Source Table not found in Model = " & SourceEntity
         exit sub
      end if
   SelectAllDestinationEntities oColect
   copyAttributesToAllTables fldr, oColect
   MsgBox  "Copyed Fields = " & iCountFields & " to " & iCountEntities & " Entities."
   output  "___Copyed Fields = " & iCountFields & " to " & iCountEntities & " Entities."
end sub
'-----------------------------------------------------------------------------
' Select All Destination Entities, that the columns will be copyed in them
'-----------------------------------------------------------------------------
Sub SelectAllDestinationEntities(oColect)
   dim iInd
   iInd = -1
  
   iInd = iInd + 1 : oColect.Add iInd , "Entity_56"
   iInd = iInd + 1 : oColect.Add iInd , "Entity_57"
   iInd = iInd + 1 : oColect.Add iInd , "Entity_58"
End Sub
'-----------------------------------------------------------------------------
' Copy all attributes from Entity A, to all the tables in the collection, if the columns are not found in them
'-----------------------------------------------------------------------------
Sub copyAttributesToAllTables(pModel, oColect_)
   
     dim i
     For i = 0 to oColect_.Count - 1
         getEntity pModel, oColect_.item(i)
         Set objDestinationEntity   = objFound
        
         if objDestinationEntity is nothing = false then
               'output "inserting into = " & objDestinationEntity.Code
            copyAttributes objSourceEntity, objDestinationEntity
            iCountEntities = iCountEntities + 1
        else
            output "Table not found in Model = " & oColect_.item(i)
         end if
      Next
      oColect_.RemoveAll
End Sub
'-----------------------------------------------------------------------------
' Recursively search for the entity and return its object
'-----------------------------------------------------------------------------
function getEntity(parentFolder_, tableCode_)
Dim obj ' running object
   For Each obj In parentFolder_.children
      if obj.ClassName="Entity" then
         if obj.Code=tableCode_ then
            'MsgBox  "Found: " & obj.Code , vbOk + vbInformation,"Info"
            Set objFound = obj
            Set getEntity = obj
            exit function
         end if
      end if
   Next
   ' go into the sub-packages
   Dim innerFolder ' running folder
   For Each innerFolder In parentFolder_.Packages
      getEntity innerFolder, tableCode_
   Next
End function
'-----------------------------------------------------------------------------
' Copy all attributes from Entity A, to B, if they are not found in B
'-----------------------------------------------------------------------------
Sub copyAttributes(entityFrom_, entityTo_)
      if entityFrom_.ClassName <>"Entity" then exit sub
     
      Dim attrOld
      Dim attrNew
     
      For Each attrOld In entityFrom_.Attributes
     
         if isAttributeInEntity(entityTo_, attrOld.code) = false then
        
            Set attrNew = entityTo_.Attributes.CreateNew
        
            attrNew.Name = attrOld.Name
            attrNew.code = attrOld.code
            attrNew.Mandatory = attrOld.Mandatory
            attrNew.Domain = attrOld.Domain
        
            iCountFields= iCountFields + 1
         End if
      Next
  
End Sub
'-----------------------------------------------------------------------------
' Return true if attribute is found in entity
'-----------------------------------------------------------------------------
function isAttributeInEntity(entity_, attributeCode_)
      if entity_.ClassName <>"Entity" then exit function
     
      Dim attr
      For Each attr In entity_.Attributes
     
         if attr.Code = attributeCode_ then
            isAttributeInEntity = true
            exit function
         end if
      Next
     
      isAttributeInEntity = false
  
End function
To report this post you need to login first.

Be the first to leave a comment

You must be Logged on to comment or reply to a post.

Leave a Reply