Извлечение документа с архивной базы в рабочую.

Sub Click(Source As Button)
    '  переносит в БД "Документы" выделенный главный и ответные документы к нему.
    ' проверяется наличие нового документа в documents.nsf и потом док. удаляется в архивной БД.
    On Error Goto Errh
    Dim session As New NotesSession    
    Dim ws As New NotesUIWorkspace        
    Dim db As NotesDatabase, workdb As NotesDatabase
    Dim uiview As NotesUIView
    Dim  workview As NotesView
    Dim doc As NotesDocument, newdoc As NotesDocument, workdoc As NotesDocument    
    Dim  newdoc2 As NotesDocument
    Dim workdoc2 As NotesDocument    
    Dim ftdocD As NotesDocument    
    Dim server As String    
    Dim dc1 As NotesDocumentCollection
    Dim dc As NotesDocumentCollection
    Dim i As Integer
    Set db = session.CurrentDatabase
    server = db.Server
    Set uiview=ws.CurrentView
    
    Set workdb = New NotesDatabase( server, "promdoc\documents.nsf" )
    Set workview = workdb.GetView("arc_check")
    Call workdb.UpdateFTIndex( False )    
    Call workview.Refresh()
    
    Set dc1 = uiview.Documents
    If dc1.Count<1 Then
        Msgbox "Необходимо выбрать по крайней мере один документ !"
        Exit Sub
    End If
    
    Set doc = dc1.GetFirstDocument '  док в арзхиве в текущей вью
    While Not doc Is Nothing
        Print    doc.header(0)
        Set workdoc = workview.GetDocumentByKey( doc.id(0))        'проверка, что дока нет в бд документы
        If workdoc Is Nothing Then
            If doc.parent(0)=""  Then   '    ГЛАВНЫЙ
                
                Set newdoc=workdb.CreateDocument        
                Call doc.CopyAllItems(newdoc,1)
                newdoc.UniversalID=doc.UniversalID
                newdoc.who="На регистрации"
                newdoc.whois="На регистрации"
                newdoc.archive = ""
                
                If doc.links(0)<>"" Then
                    Print "Есть связь"
                    Call ReplPathDoc(newdoc.UniversalID)    
                End If
                
                Call newdoc.Save(True,False)        
                Print  "Создали главный "
                
                Set dc = doc.Responses     '  Ответы
                Set ftdoc = dc.GetFirstDocument    
                i=0
                While Not ftdoc Is Nothing
                    Print  i " Создали ответ "   ftdoc.header(0)
                    i=i+1
                    Set workdoc2 = workview.GetDocumentByKey( ftdoc.id(0))         'проверка, что ответного дока нет в бд документы
                    If workdoc2 Is Nothing Then
                        Set newdoc2=workdb.CreateDocument        ' ОТВЕТ новый
                        Call ftdoc.CopyAllItems(newdoc2,1)
                        newdoc2.UniversalID=ftdoc.UniversalID
                        newdoc2.who="На регистрации"
                        newdoc2.whois="На регистрации"
                        newdoc2.archive = ""
                        Call newdoc2.Save(True,False)    
                    Else
                        Print ftdoc.header(0) "   уже был в БД Документы (ответный)"
                    End If
                    Set ftdoc = dc.GetNextDocument (ftdoc )
                Wend
                
            Else
                Messagebox "Документ ответный, выделите главный!!"
            End If
        Else
            Print doc.header(0) "   уже был в БД Документы !"
        End If
        
        Set nextdoc = dc1.GetNextDocument (doc)
        '    Call doc.Remove(True)   ' удалить Главный  с архивной
        
                  'Обновляем индекс и view в рабочей базе    
        Call workdb.UpdateFTIndex( False)    
        Call workview.Refresh()     ' в     documents вид arc_check
        Call workview.Refresh()
        
        i=0
        Set workdoc = workview.GetDocumentByKey( doc.id(0)) 
        If Not workdoc Is Nothing Then          ' если есть Главный документ в БД Докумнеты  - удаляем его из Архивной базы
            Print "есть Главный документ в БД Докумнеты"
            
            Set dc = doc.Responses    ' архивная, главный док
            Set workftdoc = dc.GetFirstDocument    
            While Not workftdoc Is Nothing                
                Print i "Удаляем ответ из Архивной - "       workftdoc.header(0)
                i=i+1
                Set ftdocD = workview.GetDocumentByKey( workftdoc.id(0))   ' Проверка - есть ли уже в БД Докумнеты
                If Not ftdocD Is Nothing Then  
                    Set worknextftdoc = dc.GetNextDocument (workftdoc )
                    Call workftdoc.Remove(True) 
                '    Print "Удален ответ  из Архивной базы"
                Else
                    Messagebox  "Ответного Нет в БД Документы! Сообщите админу."
                    Set worknextftdoc = dc.GetNextDocument (workftdoc )                    
                End If
                Set workftdoc=worknextftdoc
                Set worknextftdoc=Nothing
            Wend    
            Print  "Удаляем главный   из Архивной базы"
            Call doc.Remove(True)       '
            
        Else
            Messagebox  "Главного Нет в БД Документы! Сообщите админу."
        End If
        Print "-----------------"
        Set doc=nextdoc
        Set nextdoc=Nothing
        
    Wend
    
    Call uiview.DeselectAll
    
    Call ws.ViewRefresh
    Messagebox "Документ(ы) перенесен(ы)!"
    Exit Sub
Errh:    
    Print Error & | in line | & Erl()
End Sub

Function ReplPathDoc (url_doc As String)
    'Меняет путь в БД связей, где находится документ
    On Error Goto Errh
    Dim linksDB As NotesDatabase
    Dim Agent As NotesAgent
    Dim docRequest As NotesDocument
    Dim paramid As String
    Set ns=New NotesSession
    Set linksDB=ns.GetDatabase( ns.CurrentDatabase.Server,"Promdoc\index.nsf")
    Print "функция ReplPathDoc"
    Set docRequest = linksDB.CreateDocument     
    Set item = docRequest.AppendItemValue("doc_id", id_doc)
    Call docRequest.save(True, False)
    
    'Получаем агента(серверного с правами менеджера), передаем ему параметр(Noteid дока-запроса,и запускаем агент)
    Set agent = linksDB.GetAgent("ReplPath")
    paramid = docRequest.Noteid
    Call Agent.RunOnServer(paramid)
    Print "функция ReplPathDoc - END"
    Exit Function
Errh:    
    Print Error & | in line | & Erl()
    Exit Function
End Function