多個Notes文檔中附件批量彙總到一個文檔中

Sub Initialize() 
   
   Dim session As New NotesSession 
   Dim db As NotesDatabase 
   Dim collection As NotesDocumentCollection 
   Dim doc As NotesDocument   
   Dim rtitem As Variant 
   Dim doc2 As NotesDocument 
   Dim NotesRichTextItem As NotesRichTextItem 
   Dim NotesItem As NotesItem 
   Dim workspace As New NotesUIWorkspace 
   Dim result As Variant 
 
   result = workspace.Prompt( 13, "Choose database to save the attachments", "") 
   
   Set db = session.CurrentDatabase 
   Set collection = db.UnprocessedDocuments 
   Set doc = collection.GetFirstDocument() 
   
   If result(0) = "" & result(1) = db.Filename Then 
         Set doc2 = db.Createdocument()  
   Else 
         Dim db2 As NotesDatabase 
         Set db2 = session.GetDatabase( result(0), result(1), False ) 
         Set doc2 = db2.Createdocument() 
   End If 
   
   // 此處假定新建文檔基於表單“Main Topic”，並將附件彙總到 Body 富文本域中
   doc2.Form = "Main Topic"
   doc2.Subject = "New Attachment"
   Set NotesRichTextItem = New NotesRichTextItem( doc2, "Body" ) 
   
   While Not(doc Is Nothing)         
     // 此處假定附件是嵌入在 Body 域當中，當然也可以循環文檔所有的域，然後對於富文本域進行處理，提取附件
     Set rtitem = doc.GetFirstItem( "Body" ) 
     If ( rtitem.Type = RICHTEXT ) Then 
     ForAll o In rtitem.EmbeddedObjects 
        If ( o.Type = EMBED_ATTACHMENT ) Then     
         Call o.ExtractFile( "c:\temp\" & o.Name ) 
         Call notesRichTextItem.EmbedObject( EMBED_ATTACHMENT ,"", "c:\temp\" & o.Name) 
         Kill "c:\temp\" & o.Name 
        End If         
     End ForAll 
      End If 
   Set doc = collection.GetNextDocument(doc) 
   Wend 
   
   Call doc2.Save(False, True )   
   
 End Sub