1

Тема: Серверный агент для переноса документов в другую базу

Option Public
Option Declare

Sub Initialize
    Dim session As New NotesSession
    Dim db As NotesDatabase
    Dim respview As NotesView, uniview As NotesView
    Dim curdoc As NotesDocument, maindoc As NotesDocument, docreg As NotesDocument
    Dim  nextdoc As NotesDocument
    Dim docR As NotesDocument
    Dim RTItm As NotesRichTextItem, view As NotesView, db2 As NotesDatabase'Межмин    
    Dim server As String, databaseFileName As String
    Dim item As NotesItem
    Print "START Megved" 
    On Error GoTo Errh
    Set db=session.Currentdatabase
    
    Set view = db.GetView ("reg" )
    
    Set docreg = view.GetFirstDocument
    If docreg Is Nothing Then Print("Нет доступа к настройкам регистрации!") : Exit Sub    
    server = docreg.Router(0)   
    databaseFileName =   docreg.RouterFile(0)
    Set db2 = Session.GetDatabase(server$, databaseFileName$)
    If Not db2.Isopen Then'проверка доступа к базе Межмин'
        Print "Нет доступа к Базе Роутер!"
        Exit Sub
    End If
    
    Dim PolicyPatch As String
    Dim server_docs As String
    Dim view_policy As NotesView
    PolicyPatch = docreg.PolicyPatch(0)
    server_docs = docreg.AdresatS(0)
    Dim db_policy As NotesDatabase
    Set db_policy = session.GetDatabase(server_docs, PolicyPatch)
    If Not db_policy.Isopen Then'проверка доступа к базе Межмин'
        Print "Нет доступа к Базе Структура!"
        Exit Sub
    End If
    
    Set view_policy =db_policy.GetView("counteropen") ' Бд структура - открытый док
    Call view_policy.Refresh()
    Call view_policy.Refresh()
    Dim viewCol As NotesViewEntryCollection
    Set viewCol = view_policy.Allentries
    Print "view_policy " CStr(viewCol.Count)
    Dim entry As NotesViewEntry
    Set entry    = viewCol.GetFirstEntry
    Do While Not (entry Is Nothing)
        Print "Universalid:" entry.Columnvalues(0)
        Set entry = viewCol.GetNextEntry( entry )    
    Loop
    
    
    Dim doc_policy As NotesDocument

    Set uniview = db.getview("Mejved-out-agent")
    uniview.AutoUpdate =False
    Set curdoc = uniview.getfirstdocument

    While Not curdoc Is Nothing
        Print "curdoc.id(0) " curdoc.id(0)
        Set doc_policy=view_policy.GetDocumentByKey(curdoc.id(0))

        If (doc_policy Is Nothing) Then 
            Print  "нет UNID в структуре в counteropen (док НЕ открыт юзером)"
            Set docR = New NotesDocument( db2 ) ' создали новый док в базе роутер

            ' копируем нужные поля            
            Set item = CurDoc.GetFirstItem( "header" )
            Call docR.CopyItem (item,"ЗАГОЛОВОК")
            
            Set item = CurDoc.GetFirstItem( "adresed" )
            Call docR.CopyItem (item,"АДРЕСАТ")
            
            Set item = CurDoc.GetFirstItem( "regnom_1" )
            Call docR.CopyItem (item,"РЕГИСТРАЦИОННЫЙ_НОМЕР")
            
            Set item = CurDoc.GetFirstItem( "datereg" )
            Call docR.CopyItem (item,"ДАТА_РЕГИСТРАЦИИ")
            
            Set item = CurDoc.GetFirstItem( "NameOrg" )  'НЕИСП в XML, 
            Call docR.CopyItem (item,"NameOrg")
            
            Set item = CurDoc.GetFirstItem( "isp" )
            Call docR.CopyItem (item,"ФАМИЛИЯ")
            
            Set item = CurDoc.GetFirstItem( "Server_id" )
            Call docR.CopyItem (item,"Server_id")
            
            docR.id_doc =  CurDoc.id(0)
            
            If CurDoc.hasitem("count_adressed") Then docR.count_adressed=CurDoc.count_adressed    
            
            Set item = CurDoc.GetFirstItem( "XMLattach" )
            If Not item Is  Nothing     Then Call docR.CopyItem (item,"ПРИЛОЖЕНИЯ_")
            
            Set item = CurDoc.GetFirstItem( "IDXml" )
            Call docR.CopyItem (item,"IDXml")
            
            ' ----------------            
            docR.Form="fmejved"
            docR.fxml="0"
            docR.ТИП_ДОКУМЕНТА="Исходящий"
            
            Call docR.Save(True, True)
            CurDoc.Server_id="отправлено"
            CurDoc.flagXML="3"
            Dim Adresat As string, Adr As Variant
            Adresat=""
            Adr = CurDoc.GetItemValue( "NameOrg" )
            ForAll tmp In Adr ' все адресаты в строку
                Adresat = Adresat  +" " + tmp
            End ForAll    
            
CurDoc.history="МЭД: в " + CStr(Now) + " документ " + CurDoc.IDXml(0) + " отправил " + session.CommonUserName + " "&Chr(13)+" на "+ Adresat  +"." &Chr(13)+" "&Chr(13) + CurDoc.history(0)
            
            Call CurDoc.Save(True,False)    
            
            'Set curdoc = uniview.GetNextDocument (curdoc )    
        Else
            Print  "Док открыт у " doc_policy.fio(0)
        End If    
        
        Set nextdoc = uniview.getnextdocument(CurDoc)
        Set CurDoc=nextdoc
        Set nextdoc=Nothing
    Wend

    Exit Sub
Errh:    
    Print Error & | in line | & Erl()
    Exit Sub
End Sub

Поделиться

2

Re: Серверный агент для переноса документов в другую базу

Sub Click(Source As Button) '12.06.2020 14.00 актуализировано с CIT   v 1.0
    ' копирует документ и приложение XML в базу роутер
    On Error Goto ErrH    
    Print "В Межвед отправка"    
    Dim Session As New NotesSession, datapatch As String, uiworkspace As New NotesUIWorkspace, CurDataBase As NotesDataBase
    Dim Name_ As New NotesName(Session.UserName), rtitemA As NotesRichTextItem
    Dim RTItm As NotesRichTextItem, view As NotesView, db2 As NotesDatabase'Межмин    
    Dim dt As New NotesDateTime("Nothing/null"), item As NotesItem, items As NotesItem, DocColl As NotesDocumentCollection, uiDoc As NotesUIDocument    
    Dim CurDoc As NotesDocument 'документ   ВЭД
    
    If uiworkspace.Prompt (PROMPT_YESNO, "Внимание",    "Отправить подписанный документ в МЕЖВЕД?") <> 1 Then Exit Sub
    
    Set CurDataBase=Session.CurrentDataBase
    
    Set CurDoc=uiworkspace.CurrentDocument.Document
    Set uidoc = uiworkspace.CurrentDocument
    Call uidoc.save
    
    If CurDoc.Server_id(0) ="отправлено" Then
        Messagebox "Документ уже был отправлен в МЭД!"
        Exit Sub
    End If
    
    If CurDoc.HasEmbedded Then
        Set rtitemA = CurDoc.GetFirstItem("XMLattach" )
        If Isempty( rtitemA.EmbeddedObjects) Then
            Messagebox "В документе нет xml для отправки"
            Exit Sub
        Else
            
            Forall obj In rtitemA.EmbeddedObjects
                If  ( obj.Type = EMBED_ATTACHMENT ) Then    
                    If    Lcase(Strrightback(obj.Source , ".")) = "xml"  Then
                        Print obj.Source 
                    Else 
                        Messagebox        "Нет подписанного вложения XML"    
                        Exit Sub
                    End If
                End If
            End Forall
        End If
    End If
    
    CurDoc.Server_id="готов к отправке"
    
    CurDoc.history="МЭД: в " + Cstr(Now) + " документ " + CurDoc.IDXml(0) + " отправил " + session.CommonUserName + " "&Chr(13)+"  на ВЭД сервер для МЕЖВЕДа.... "
    
    
    Call CurDoc.Save(True,False)    
    
    Messagebox "Документ успешно отправлен в ВЭД  для МЭД!"
    
    Call uidoc.Reload
    
    Print "В Межвед отправка - конец"    
    Exit Sub
ErrH:
    Print "Межвед! - Ошибка: " & Error(Err) & " в строке " & Erl
    Exit Sub
End Sub

Поделиться