[Notes]每月備存後比對刪除

%REM
Agent DelOverTime
Created 2018/1/15 by joey lee/Kinsus
Description: Comments for Agent
%END REM
Option Public
'Option Declare

Sub Initialize
On Error GoTo sub_ErrHandle
Dim sess As New NotesSession
Dim db As NotesDatabase
Dim ArchiveDB As NotesDatabase
Dim dc As NotesDocumentCollection
Dim dc2 As NotesDocumentCollection
Dim dc3 As NotesDocumentCollection
Dim view As NotesView
Dim doc As NotesDocument
Dim HisDoc As NotesDocument
Dim Macro As String
Set db = sess.Currentdatabase
Dim FilePath As String
Dim YearI As Integer
Dim MonthI As Integer
Dim HisCount As Integer
Dim ProdCount As Integer
Dim prefix As String
Dim DocNo As String
Dim x As Integer
StartTime = Now
YearI = Year(Now)
MonthI = Month(Now)
qstr2 = |Form='Issue':'fAttachDoc' & @Created < @TextToTime("| +  CStr(yearI) + |/| + CStr(MonthI) + |/01")|
If MonthI = 1 Then
MonthI = 12
YearI = YearI -1
Else
MonthI = MonthI -1
End If
'20018/10/15 Joey Lee Add
qstr2 = qstr2 & " | YM ='" &  CStr(yearI) &  CStr(MonthI) & "'"
prefix = "Contact\contact_" + CStr(YearI) +  Right("0" + CStr(MonthI),2)
' 先檢查是否複製成功
For i = 0 To 1
If i = 0 Then '附件資料庫
ArchiveFilePath = prefix + "_file.nsf"
MainFilePath = "DocLib\Contact_File.nsf"
Else '文件資料庫
ArchiveFilePath = prefix + ".nsf"
MainFilePath = "DocLib\Contact.nsf"
End If
Set DB = sess.getdatabase("K01A05/Kinsus", MainFilePath)
If Not DB Is Nothing Then
Set ArchiveDB = sess.getDatabase("K01A99/Kinsus", ArchiveFilePath)
If Not ArchiveDB Is Nothing Then
Set dc = ArchiveDB.search(qstr2, Nothing , 0 )
HisCount = dc.count
Set dc2 = DB.Search(qstr2,Nothing,0)
ProdCount = dc2.count
If dc.Count > 0 Then '備存DB有文件
'If HisCount >= ProdCount or i=1 Then '備份有完整
If HisCount >= ProdCount Then '備份有完整
Print "Delete " & dc2.count & " docs."
Call dc2.Removeall(True)  ' 刪除正式區的過期文件
EndTime = Now
mStr = "開始於 " & StartTime & " 結束於 " & EndTime
mStr = mStr & "，正式資料庫刪" & dc2.Count & "份 "
Call MailTo("N","[聯絡單文件備份]: " & mStr )
Else ' 正式區文件數小於備份區   181015 Add by Joey
If i = 1 Then
'docNo = doc.Getitemvalue("DocFullNo")(0)
key = "DocFullNo"
Else
'docNo = doc.Getitemvalue("FileNo")(0)
key = "FileNo"
End If
Set view =  ArchiveDB.Getview("vAll")
If Not view Is Nothing Then
For j=1 To dc2.Count
Set doc = dc2.Getnthdocument(j)
docNo = doc.Getitemvalue(key)(0)
If docNo <> "" And docNo <> "*" Then
Set dc3 = view.Getalldocumentsbykey(docNo)
If dc3.Count > 0 Then  ' 於歷史區有找到
'Call doc.Remove(true)
Else '沒備到
Call doc.CopyToDatabase( ArchiveDB )
'Call doc.replaceitemValue("bFlag","1")
'Call doc.save(True,False)
x = x+1
mStr = mStr & docNo & chr(10)
End If
Call doc.Remove(True)
%REM
Set HisDoc = view.Getdocumentbykey(docNo)
If HisDoc Is Nothing Then
Call doc.CopyToDatabase( ArchiveDB )
Call doc.replaceitemValue("bFlag","1")
Call doc.save(True,False)
x = x+1
mStr = mStr & docNo & Chr(10)
Else
Call doc.Remove(True)
End If
%END REM
End If
Next
End If
Print "Backup: " & x
Call MailTo("N","[聯絡單文件備份]: " & mStr )
End If
End If
End If
End If
Next
Exit Sub

sub_ErrHandle :
VerifyDoc = False
Set  mailDoc =New  NotesDocument(db)
mailDoc.Form="Memo"
mailDoc.SendTo= "joey lee/Kinsus"
subject$=db.Server + " : " + db.Title & ". Agent :...<刪除過期附件>   Error  : " & Error() & " Err line : " & CStr(Erl())
mailDoc.Subject=subject$
Set rtitem = New NotesRichTextItem(MailDoc,"Body")
Call rtitem.Addnewline(1)
Call rtitem.Appendtext("Error Line : " & CStr(Erl) & " , Error Code : " & CStr(Err) & " , Error : " & Error)
Call rtitem.Addnewline(2)
Print  subject$
Call  mailDoc.Send(False)
Exit Sub
End Sub
Sub MailTo(f,ss)
Dim session As New NotesSession
Dim db As NotesDatabase
Dim mailDoc As NotesDocument
Dim rtitem As NotesRichTextItem

Set db = session.CurrentDatabase
Set mailDoc = New NotesDocument(db)

Call mailDoc.ReplaceItemValue("Form","Memo")
If f = "N" Then
Call mailDoc.ReplaceItemValue("Subject","備份聯絡單文件資訊(階段通知)")
ElseIf f = "E" Then
Call mailDoc.ReplaceItemValue("Subject","備份聯絡單文件發生錯誤")
ElseIf f = "F" Then
Call mailDoc.ReplaceItemValue("Subject","備份聯絡單文件已完成....")
End If

Set rtitem = New NotesRichTextItem(mailDoc,"Body")
Call rtitem.AppendText(ss)
Call mailDoc.Send(False,"joey lee/kinsus")
End Sub