多个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