Перенос документов "связей" между базами.

Данный агент переносит все документы связей с БД LoglinksSMI в БД Loglinks
Sub Click(Source As Button)
    Dim session As New NotesSession
    Dim ws As New NotesUIWorkspace
    Dim db As NotesDatabase
    Dim db2 As NotesDatabase
    Dim view As NotesView, view2 As notesview
    Dim dc As NotesDocumentCollection
    Dim curdoc As NotesDocument, doc As NotesDocument, ftdoc As NotesDocument, newdoc As NotesDocument
    Dim nextdoc As NotesDocument
    Dim item As NotesItem, item2 As NotesItem, item3 As NotesItem
    Dim server As String, formula As String, str1 As String
    Dim i As Variant
    i=0
   
    On Error Goto ErrH
    server=session.CurrentDatabase.Server
    Set db=session.GetDatabase(server,"promdoc\LoglinksSMI.nsf")
    Set db2=session.GetDatabase(server,"promdoc\Loglinks.nsf")
    Set curdoc=ws.CurrentDocument.Document
    Set view=db.GetView("connect")
    Set doc=view.GetFirstDocument
    While Not doc Is Nothing
        Print doc.header(0)
        If  doc.whois(0) = "В архиве"  Then
            doc.BASE_NAME = "promdoc\documentsSMI.nsf"
        Else
            Print doc.whois(0)
        End If
        doc.Serv_name ="MIITK"
        doc.ADDREADERS=Arrayunique(doc.ADDREADERS)
        doc.USER ="SMI"
        Call doc.Save(True, False)
        Print "Сохранили"
       
        Set newdoc=db2.CreateDocument   
        Call doc.CopyAllItems(newdoc,1)
        newdoc.UniversalID=doc.UniversalID
        Call newdoc.ComputeWithForm(0,0)
        Call newdoc.Save(True,False)
        Print "Создали новый"
       
        Set nextdoc = view.getnextdocument(doc)
        Set doc=nextdoc
        Set nextdoc=Nothing
        i=i+1
        Print Cstr(i)
    '    If i = 2 Then Exit Sub
    Wend
    Msgbox "Замена  прошла успешно"
    Exit Sub
ErrH:
    Msgbox "Ошибка  " & Error(Err) & " в строке " & Erl   
    Exit Sub
End Sub