Option Declare
Use "Common"
Dim StringTable As mailtoolsstringtable
Sub Initialize
On Error Goto Trap
Dim s As New NotesSession
Dim uiws As New NotesUIWorkspace
Dim uiv As NotesUIView
Dim policyList As Variant
Dim result As Integer
Dim justOne As Boolean
Dim policy As String
Dim collection As NotesDocumentCollection
Dim dlgNote As NotesDocument
Dim needsSetup, view As String
Set StringTable = New mailtoolsstringtable
Set db = s.currentdatabase
'comment the following if you FolderReferences performance concerns.
If Not (db.FolderReferencesEnabled) Then
db.FolderReferencesEnabled = True
End If
Set uiv = uiws.CurrentView
view = uiv.View.Name
Set collection = db.unprocesseddocuments
If s.Notesbuildversion < 167 Then
Goto ArchivePreRnext
End If
Archive:
policyList = db.ArchiveDestinations
If Fulltrim( policyList(0) ) = "" Then
needsSetup = |In order to archive selected documents you must have at least one archive setting enabled that specifies an archive database destination. To change your archive settings use the Actions->Archive->Settings menu item.|
Goto Trap
End If
If Ubound(policyList) = 0 Then
policy = policyList(0)
justOne = True
Goto SkipDialog
End If
'prompt for which policy to archive to
Set dlgNote = s.currentDatabase.createDocument
Call dlgNote.replaceitemvalue("tmpListOfPolicies", Fulltrim(policyList))
Call dlgNote.replaceitemvalue("tmpPrompt", |Select an Archive Destination:|)
' load up ArchivePolicyList Dialog
result = uiws.DialogBox("(RepeatOpenList)", True, True, False, , , , "Move to Archive Destination", dlgNote, True)
' if user didn't cancel, send collection to selected policy
If result <> False Then
policy = dlgNote.GetItemValue("tmpPolicySelected")(0)
justOne = True
End If
SkipDialog:
If justOne Then
Call archiveAttachments( collection, policy, view )
Call uiws.Viewrefresh()
End If
Exit Sub
ArchivePreRNext:
If YesNoPrompt(StringTable.GetString(TOOL_STRING+76,collection.count),StringTable.GetString(TOOL_STRING+75,Null)) Then
Call archiveAttachments( collection,"Archive Profile", view )
Call uiws.Viewrefresh()
End If
Exit Sub
Trap:
Call DisplayWarn(needsSetup & Error$ & Chr(10),MB_OK,StringTable.GetString(TOOL_STRING+75,Null))
Exit Sub
End Sub
Sub archiveAttachments(cdoc, policy, view)
On Error Goto Trap
Dim s As New NotesSession
Dim doc As NotesDocument
Dim adb As NotesDatabase
Dim adoc As NotesDocument
Dim rtitem As NotesRichTextItem
Dim filenames, archiveloc, archivepath, needsSetup As String
Dim obj As NotesItem
Dim doArchive As Boolean
archivepath = db.getarchivepath(policy)
archiveloc = ""
Set adb = s.GetDatabase(archiveloc, archivepath)
If adb Is Nothing Then
needsSetup = |The selected archive does not exist in this location: | + archiveloc + |:| + archivepath + |.|
Goto Trap
End If
'Move the documents that have attachments to the archive file and then replace
'the attachment in the original with a doc link to the archived copy
Set doc = cdoc.GetFirstDocument
While Not doc Is Nothing
doArchive = False
If (doc.HasEmbedded) Then
Set rtitem = doc.GetFirstItem("Body")
Set adoc = adb.CreateDocument
Call doc.CopyAllItems(adoc,True)
If Not rtitem Is Nothing Then
If Isarray(rtitem.EmbeddedObjects) Then
Forall o In rtitem.EmbeddedObjects
If o.Type = EMBED_ATTACHMENT Then
doArchive = True
If filenames = "" Then
filenames = o.Name
Else
filenames = filenames + ", " + o.Name
End If
Call o.Remove
End If
End Forall
Elseif Isarray(doc.EmbeddedObjects) Then
Forall o In doc.EmbeddedObjects
If o.Type = EMBED_ATTACHMENT Then
doArchive = True
If filenames = "" Then
filenames = o.Name
Else
filenames = filenames + ", " + o.Name
End If
Call o.Remove
End If
End Forall
End If
Else
'If all else fails, Check for earlier notes version attachments
Set obj = doc.GetFirstItem("$File")
While Not obj Is Nothing
doArchive = True
If filenames = "" Then
filenames = obj.Values(0)
Else
filenames = filenames + ", " + obj.Values(0)
End If
obj.Remove
Set obj = doc.GetFirstItem("$File")
Wend
End If
If doArchive Then
'Move new archive docs to the appropriate folders and then save the doc link to the original.
Call adoc.save(True, True)
If (db.FolderReferencesEnabled) Then
Forall fref In doc.FolderReferences
Call adoc.PutInFolder(fref, True)
End Forall
Else
Call adoc.PutInFolder(view, True)
End If
If rtitem Is Nothing Then
Set rtitem = New NotesRichTextItem( doc, "Body" )
End If
Call rtitem.AddNewline(2)
Call rtitem.AppendDocLink( adoc, "Link to archived attachments: "+filenames)
Call rtitem.AppendText(" Link to archived attachments: "+filenames)
Call doc.Save(True, True)
filenames = ""
End If
End If
Call s.UpdateProcessedDoc(doc)
Set doc = cdoc.GetNextDocument(doc)
Wend
Exit Sub
Trap:
Call DisplayWarn(needsSetup & Error$ & Chr(10),MB_OK,StringTable.GetString(TOOL_STRING+75,Null))
Exit Sub
End Sub