Sub Initialize
On Error GoTo err_label_archive
Dim session As New NotesSession
Dim Profile As NotesDocument
Dim db As NotesDatabase
Dim dbArc As NotesDatabase
Dim dc As NotesDocumentCollection
Dim doc As NotesDocument
Dim nxtdoc As NotesDocument
Dim dcChild As NotesDocumentCollection
Dim docChild As NotesDocument
Dim nxtdocChild As NotesDocument
Dim RemoveAfterArchiving As integer
Dim answer As Integer
Dim cntDel As long
Dim cntDelOK As long
Dim cntArc As Integer
Dim i As Long
Dim errStr As String
Set db = session.CurrentDatabase
Set Profile = db.GetProfileDocument("DatabaseProfile")
Set dbArc = New NotesDatabase("emperor/KRD", Profile.ArchiveDB(0))
If dbArc Is Nothing Then
Print " Не найдена база данных " & Profile.ArchiveDB(0)
Exit sub
End If
If Not dbArc.isopen() Then
Print " Не доступна база данных " & Profile.ArchiveDB(0)
Exit Sub
End If
cntDel = 0
cntDelOK = 0
cntArc = 0
If db.CurrentAccessLevel <> 6 Then
MsgBox "Access denied", 0, ca
Exit Sub
End If
'//
'// Запрос на удаление документов
'//
RemoveAfterArchiving = 0
If MessageBox("Delete documents after archiving?", MB_YESNO) = 6 Then RemoveAfterArchiving = 1
'//
'// Архивирование документов
'//
Set dc = db.UnprocessedDocuments
Set doc = dc.GetFirstDocument
i = 0
While Not(doc Is Nothing)
If Not doc.hasitem("Archived") then
Call doc.CopyToDatabase(dbArc)
Call doc.replaceitemvaue("Archived", "1")
Call doc.save(True,doc.Isresponse)
If i Mod 100 = 0 Then
Print "Archiving : " & Format(i / dc.Count * 100, "Standard") & "%"
End If
i = i + 1
cntArc = cntArc + 1
End if
Set doc = dc.GetNextDocument(doc)
Wend
Print "Archiving : 100%"
On Error GoTo err_label_delete
' Удаление документов
i = 0
cntDelOK = 0
cntDel = 0
If RemoveAfterArchiving = 1 Then
Set doc = dc.GetFirstDocument
While Not(doc Is Nothing)
Set nxtdoc = dc.Getnextdocument(doc)
' Если главный документ
If Not doc.IsResponse Then
' Получаем список всех подчиненных документов
Set dcChild = doc.Responses
If Not dcChild.Count < 1 Then
Set docChild = dcChild.Getfirstdocument()
While Not docChild Is nothing
Set nxtdocChild = dcChild.Getnextdocument(docChild)
' По очереди удаляем подчиненные документы
Call docChild.Remove(true)
cntDelOK = cntDelOK + 1
i = i + 1
nxtChild:
Set docChild = nxtdocChild
Wend
End if
End if
Call doc.Remove(True)
cntDel = cntDel + 1
i=i+1
If i Mod 100 = 0 Then Print "Deleting : " & Format(i / dc.Count * 100, "Standard") & "%"
nxtMainDoc:
Set doc = nxtdoc
wend
End If
Print "Deleting : 100%"
GoTo exit_label
err_label_archive:
errStr = "Error at line: " & Erl & " Error: " & Error$
if Not doc Is nothing Then errStr = errStr & doc.UniversalID & "; InNum=" & doc.InNum(0)
Print errStr
Resume exit_label
err_label_delete:
errStr = "Error at line: " & Erl & " Error: " & Error$
If Not docChild Is Nothing Then errStr = errStr & doc.UniversalID & "; InNum=" & doc.InNum(0) & "; "
If Not doc Is Nothing Then errStr = errStr & doc.UniversalID & "; InNum=" & doc.InNum(0)
Print errStr
If Not nxtdocChild Is Nothing Then Resume nxtChild ' продолжаем удалять дочерние
If Not nxtdoc Is Nothing Then Resume nxtMainDoc ' продолжаем удалять основные
Resume exit_label
exit_label:
Print "Arciving: " & cntArc & "; DelMainDoc: " & cntDel & "; DelRespDoc: " & cntDelOK
End Sub
