Function dispatch_object(obj As NotesEmbeddedObject, Byval s_dir$, s_file$) As Boolean
    ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    ' выгрузка прикреплений и ole в указанный каталог с указанным именем файла
    On Error Goto ErrLab
    Dim FR As Boolean
    Dim handleV As Variant
    Dim s_ext$, s_tmp$
    
    If obj.Type = EMBED_ATTACHMENT Then
        obj.ExtractFile(s_dir + "\" + s_file)
    Elseif obj.Type = EMBED_OBJECT Then
        s_tmp = Lcase(obj.Class)
        If Instr(s_tmp, "word") Then
            s_ext = ".doc"
        Elseif Instr(s_tmp, "excel") Then
            s_ext = ".xls"
        Elseif Instr(s_tmp, "powerpoint") Then
            s_ext = ".ppt"
        Elseif Instr(s_tmp, "visio") Then
            s_ext = ".vsd"
        Else
            s_ext = ""
        End If
        Set handleV = obj.Activate( False )
        s_file = s_file + s_ext        ' Так может измениться расширение при записи
        Call handleV.SaveAs(s_dir + "\" + s_file)        
        Call handleV.Close
    End If
    FR = True
    
EndLab:
    dispatch_object = FR
    Exit Function
ErrLab:
    FR = False
    Goto EndLab
End Function

Function copy_richtext(ws As NotesUIWorkspace, rtitm As NotesRichTextItem, Byval s_comment$, _
objApp As Variant, objDoc As Variant, Byval s_target_dir$) As Boolean
    ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    
    ' копирование через буфер содержимого поля rtitm в заданный документ заданного приложения word (текст предваряется комментарием s_comment)
    ' выгрузка в указанный каталог всех прикреплений и ole из данного rtf-поля
    On Error Goto ErrLab
    Dim uid As NotesUIDocument
    Dim itm As NotesItem, doc As NotesDocument, obj As NotesEmbeddedObject
    Dim s_text$, s_file$
    Dim n_ole%
    Dim arEO As Variant
    Dim FR As Boolean
    Set doc = rtitm.Parent
    Call doc.ReplaceItemValue("Form", "BODYFORM")
    Set uid = ws.EditDocument(False, doc, False, "", True)
    On Error Resume Next
    Call uid.ExpandAllSections()
    On Error Goto ErrLab
    Call uid.SelectAll()
    Call uid.Copy        ' копируем в буфер
    Call uid.Close(True)
    ' добавляем разделитель документов
    With objApp.Application.Selection
        .TypeText("= = = = = = = = = = = = = = = = = = = = = = = = = = ")
        .TypeParagraph
        If s_comment <> "" Then
            .Font.Bold = True
            .Font.Size = 20
            .TypeText(s_comment)
            .Font.Bold = False
            .Font.Size = 12
            .TypeParagraph
        End If
        .TypeText("= = = = = = = = = = = = = = = = = = = = = = = = = = ")
        .TypeParagraph
    End With
    Call objApp.Application.Selection.PasteAndFormat(0)
    s_text = ""
    n_ole = 0
    On Error Resume Next
    arEO = rtitm.EmbeddedObjects
    On Error Goto ErrLab
    If Isarray(arEO) Then
        Forall o In rtitm.EmbeddedObjects
            Set obj = o
            If obj.Name = obj.Source Then
                s_file = obj.Source
            Else
                s_file = obj.Name + "-" + obj.Source
            End If
            If dispatch_object(obj, s_target_dir, s_file) Then
                Call objApp.Application.Selection.TypeParagraph
                Call objDoc.Hyperlinks.Add( objApp.Application.Selection.Range, s_file,"","", "Приложение: " + s_file, "")
            Else
                n_ole = n_ole + 1
            End If
        End Forall
        If n_ole > 0 Then
            s_text = "Имеется " + Cstr(n_ole) + " не выгруженных OLE-объектов"
            With objApp.Application.Selection
                .TypeParagraph
                .TypeParagraph
                .Font.Color = 255
                .Font.Bold = True
                .Font.Size = 18
                .TypeText(s_text)
                .Font.Color = 0
                .Font.Bold = False
                .Font.Size = 12
            End With
        End If
        Erase arEO
    End If
    With objApp.Application.Selection
        .TypeParagraph
        .TypeParagraph
        .TypeParagraph
    End With
    FR = True
EndLab:
    copy_richtext = FR
    Exit Function
ErrLab:
    FR = False
    Goto EndLab
End Function

Function copy_richtext_collection(col As NotesDocumentCollection, Byval s_richtext_name$, Byval s_caption_formula$, Byval s_dir_name$, Byval s_file_name$)
    ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    ' выгрузка rt-полей из заданной коллекции документов в заданный каталог с указанным именем
    
    On Error Goto ErrLab
    Dim ws As New NotesUIWorkspace
    Dim session As NotesSession
    Dim db As NotesDatabase
    Dim doc As NotesDocument, tmpdoc As NotesDocument
    Dim k%, n%
    Dim s_comm$
    Dim v_result As Variant
    Dim itm As NotesItem, rti As NotesRichTextItem
    Set db = col.Parent
    Set session = db.Parent
    Dim wdApp As Variant, wdDoc As Variant
    Set wdApp = CreateObject("Word.Application")        ' открыли Word
    If wdApp.Application.Visible Then
        Call wdApp.Application.Documents.Close
        wdApp.Application.Visible = False
    End If
    Call wdApp.Application.Documents.Add
    Set wdDoc = wdApp.Application.Documents(1)
    n = col.Count
    For k = 1 To n
        Set doc = col.GetNthDocument(k)
        If doc.HasItem(s_richtext_name) Then
            Set itm = doc.GetFirstItem(s_richtext_name)
            If const_rti_name <> s_richtext_name Then
                Set tmpdoc = New NotesDocument(db)
                Set itm = itm.CopyItemToDocument(tmpdoc, const_rti_name)
            End If
            If itm.Type = 1 Then
                Set rti = itm
                v_result = Evaluate(s_caption_formula, doc)
                If Isarray(v_result) Then
                    s_comm = v_result(0)
                    Erase v_result
                Else
                    s_comm = Cstr(v_result)
                End If
                Call copy_richtext(ws, rti, s_comm, wdApp, wdDoc, s_dir_name)
            End If
        End If
    Next k
    Call wdDoc.SaveAs(s_dir_name + "\" + s_file_name)        ' МОЖНО НАЗВАТЬ КАК ХОТИМ
    'wdApp.Application.Visible = True
    Call wdApp.Application.Quit
    'КОНЕЦ ПОДПРОГРАММЫ
EndLab:
    Exit Function
ErrLab:
    Msgbox "Agent Sub copy_richtext_collection" + Chr(13) _
    + "Line " + Cstr(Erl) + Chr(13) _
    + "Error " + Cstr(Err) + Chr(13) _
    + Error
    Goto EndLab
End Function