'-----------------------------------------------------------------------------
' Initialization
'-----------------------------------------------------------------------------
Const CONNECTION = "Provider=SQLOLEDB.1;Password=yurakasp;Persist Security Info=True;" &_
"User ID=okr;Initial Catalog=CTD_DB;Data Source=SQL01-SRV;Use Procedure for Prepare=1;" &_
"Auto Translate=True;Packet Size=4096;Workstation ID=ABK-511C-PC;" &_
"Use Encryption for Data=False;Tag with column collation when possible=False"

Dim cnx ' connection object
set cnx = CreateObject("ADODB.Connection")
cnx.Open CONNECTION

Dim rs ' recordset


'-----------------------------------------------------------------------------
' Main function
'-----------------------------------------------------------------------------
Dim mdl ' the current model
Set mdl = ActiveModel
If (mdl Is Nothing) Then
   MsgBox "There is no current model"
ElseIf Not mdl.IsKindOf(PdOOM.cls_Model) Then
   MsgBox "The current model is not an OOM model."
   
end  if
' тут ваша выборка - сообразите сами
set rs = cnx.Execute("SELECT ad.SIGNATURE, ad.COPRORATION_NAME, ad.CORPORATION_DESIGN,	a.SIGNATURE as ROOT" &_
" FROM  dbo.INFO_CORPORATION ad, dbo.INFO_CORPORATION a WHERE  (a.ID = ad.ID_PARENT) ")


   '
   Dim Map 'Для поиска исвязи объектов после загрузки
  
   Set Map = CreateObject("Scripting.Dictionary")


Do Until rs.EOF 
   '
... далее, что вам нужно загрузить
...

 Map.add ou, rs("SIGNATURE") 'Fill map 
 rs.MoveNext
  
Loop

 Dim ou 'Object
 set ou=mdl.{ClassObject}.createnew
 ' далее присвоить свойства - типа
 AddObjectProperties  rs , ou


' Вот простой вариант - исправте, что Вам надо
Private Sub AddObjectProperties (S, T)

         on error resume next
         T.Code = S("Code")
         
         if err.number <>  0  then
            err.number= 0 
            T.Delete()
            exit sub
         end if
         T.Name = S("Name")
         
         if err.number <>  0  then
            err.number= 0 
            T.Delete()
            exit sub
         end if
         T.Description = S("Descriptio") 
         T.Annotation = S("Annotation")      
         T.Comment = S("Descriptio")
         T.Stereotype = S("ExtendedObject")'"role"
         on error goto  0        
End Sub