Sub Click(Source As Button)
    Dim Session As New NotesSession    
    Dim uiworkspace As New NotesUIWorkspace    
    Dim CurDataBase As NotesDataBase
    
    server$ = "M"
    databaseFileName$ = "Docoborot\R.nsf"
    Dim db2 As NotesDatabase'Межмин
    Set db2 = session.GetDatabase(server$, databaseFileName$)
    If Not db2.Isopen Then'проверка доступа к базе Межмин'
        Messagebox "Нет доступа к Базе Р!"
        Exit Sub
    End If
    
    Dim dt As New NotesDateTime("Nothing/null")
    Dim item As NotesItem
    Dim View As NotesView
    Dim DocColl As NotesDocumentCollection    
    Dim CurDoc As NotesDocument 'документ   М'
    Dim docR As NotesDocument'документ Межмин'
    Dim doc As NotesDocument
    
    Set CurDoc=uiworkspace.CurrentDocument.Document
    Set CurDataBase=Session.CurrentDataBase
    
    
    If  CurDoc.Server_id(0) <> "" Then
        Messagebox "Документ уже был отправлен в Р"
        Exit Sub
    End If    
    
    If  CurDoc.РЕГИСТРАЦИОННЫЙ_НОМЕР(0) = "" Then
        Messagebox "Документ не зарегистрирован в ведомственном документообороте!"
        Exit Sub
    End If    
    
    Set View=db2.getView("org") 
    If View Is Nothing Or Isnull(View) Then
        Messagebox ErrorMessag$+Chr(13) +"Не найдено представление Организации-межмин"         
        Exit Sub
    End If        
    Set DocColl = uiworkspace.PickListCollection(PICKLIST_CUSTOM, False, server$, databaseFileName$, View.Name, "Выбор Адресата","раскройте список")
    
    If DocColl.Count=0 Then
        Exit Sub
    End If
    
    Set doc = DocColl.GetFirstDocument ' док в базе кор-адресаты
    CurDoc.Server_id = doc.Server_id  'записали ID получателя
    
    
    
    Set docR = New NotesDocument( db2 ) ' создали новый док в базе роутер
    
        ' копируем нужные поля            
    
    Set item = CurDoc.GetFirstItem( "ОРГАНИЗАЦИЯ" )
    Call docR.CopyItem (item,"ОРГАНИЗАЦИЯ")
    
    Set item = CurDoc.GetFirstItem( "ЗАГОЛОВОК" )
    Call docR.CopyItem (item,"ЗАГОЛОВОК")
    
    Set item = CurDoc.GetFirstItem( "АДРЕСАТ" )
    Call docR.CopyItem (item,"АДРЕСАТ")

Set item = CurDoc.GetFirstItem( "ПРИЛОЖЕНИЯ_" )
    Call docR.CopyItem (item,"ПРИЛОЖЕНИЯ_")

    Set rtitem_R = New NotesRichTextItem ( docR, "ПРИЛОЖЕНИЯ_" )
    If Not Isempty(CurDoc.ПРИЛОЖЕНИЯ_) Then 
    Call rtitem_R.AppendRTItem( CurDoc.GetFirstItem("ПРИЛОЖЕНИЯ_" ))
    End If    

    Dim rtitemA As NotesRichTextItem
    Dim rtitemB As NotesRichTextItem
    Set rtitemA = CurDoc.GetFirstItem("ПРИЛОЖЕНИЯ_" )
    Set rtitemB  = New NotesRichTextItem( docR, "ПРИЛОЖЕНИЯ_" )
    Call rtitemB.AppendRTItem( rtitemA )
    Call rtitemB.Update

datapatch$= {C:\XML\}   
    Dim rtitemA As NotesRichTextItem
    Dim rtitem As NotesRichTextItem
    Set rtitem = New NotesRichTextItem( docR, "ПРИЛОЖЕНИЯ_" )
    Dim object As NotesEmbeddedObject
    If CurDoc.HasEmbedded Then    
        Set rtitemA = CurDoc.GetFirstItem("ПРИЛОЖЕНИЯ_" )
        Forall obj In rtitemA.EmbeddedObjects        
            If  ( obj.Type = EMBED_ATTACHMENT ) Then
                Call obj.ExtractFile( datapatch$ & obj.Source )
                Set object = rtitem.EmbedObject  (EMBED_ATTACHMENT,  "", datapatch$ & obj.Source)        
                Kill     datapatch$ & obj.Source 
            End If
        End Forall
    End If

Dim itemA As NotesItem
    Set itemA = CurDoc.GetFirstItem( "ПРИЛОЖЕНИЯ_" )
    Call itemA.CopyItemToDocument(docR, "ПРИЛОЖЕНИЯ_")
    
    Set item=CurDoc.GetFirstItem( "СОДЕРЖАНИЕ_" )
    Call docR.copyitem(item, "СОДЕРЖАНИЕ_") 

Set item = CurDoc.GetFirstItem( "ФАМИЛИЯ" )
    Call docR.CopyItem (item,"ФАМИЛИЯ")
    Set item = CurDoc.GetFirstItem( "ТЕЛЕФОН" )
    Call docR.CopyItem (item,"ТЕЛЕФОН")
    
    Set item = CurDoc.GetFirstItem( "Server_id" )
    Call docR.CopyItem (item,Server_id)
' ----------------            
    docR.Form="fmejved"
    docR.fxml="0"
    Call docR.Save(True, True)
    
    CurDoc.Server_id="отправлено"
    Call CurDoc.Save(True,True)    
End Sub