Исходный текст

Option Explicit
Call ImportObjects("TDMS database for test", "OBJECT_PROGRAM")


'==============================================================================
'Имитировать импорт объектов заданного типа с Рабочего стола одного приложения в другое
'==============================================================================
Sub ImportObjects(strAppName, strObjDefID)
        Dim Apps, App, AppFrom, ObjDef, NewObjDef, ObjectsFrom, ObjFrom, ObjectsTo, NewObject

        'Получить коллекцию запущенных приложений
        Set Apps = ThisApplication.Utility.RunTDMSApplications 
        
        'Получить ссылку на приложение с указанным именем strAppName
        Set AppFrom = Nothing 
        For Each App In Apps 
                If StrComp(App.DataBaseName, strAppName) = 0 Then 
                        Set AppFrom = App 
                        Exit For
                End If
        Next 
        
        'Если приложение не найдено, закончить работу
        If AppFrom Is Nothing Then 
                MsgBox "Приложение """ & strAppName & """ не найдено.", vbExclamation
                Exit Sub
        End If
        
        'Получить ссылку на нужный тип объекта 
        Set ObjDef = AppFrom.ObjectDefs(strObjDefID) 
        If ObjDef Is Nothing Then 
                MsgBox "Тип объекта """ & strObjDefID & """ не найден.", vbExclamation
                Exit Sub
        End If
        
        'Создаем в текущей базе новый тип объекта strObjDefID
        Set NewObjDef = ThisApplication.ObjectDefs.Create 
        NewObjDef.Description = ObjDef.Description 
        NewObjDef.Icon = ObjDef.Icon 
        
        'Берем объекты из той базы и создаем такие же в нашей. Атрибуты и файлы в данном
        'случае не копируются, но должны переноситься подобным же образом - поэлементно
        Set ObjectsFrom = AppFrom.Desktop.ObjectsByDef(ObjDef)
        Set ObjectsTo = ThisApplication.Desktop.Objects 
        For Each ObjFrom In ObjectsFrom 
                Set NewObject = ObjectsTo.Create(NewObjDef) 
                NewObject.Description = ObjFrom.Description 
        Next 
        
        'Обновить Рабочий стол
        ThisApplication.Shell.Update thisApplication.Desktop
End Sub
'==============================================================================