Выгрузка из lotus в Word

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

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