Lotus Notes 数据库中附件的批量导出

				
 Type BROWSEINFO 
 hOwner As Long 
 pidlRoot As Long 
 pszDisplayName As String 
 lpszTitle As String 
 ulFlags As Long 
 lpfn As Long 
 lParam As Long 
 iImage As Long 
 End Type 

 Const BIF_RETURNONLYFSDIRS = &H1 
 Const BIF_DONTGOBELOWDOMAIN = &H2 
 Const BIF_STATUSTEXT = &H4 
 Const BIF_RETURNFSANCESTORS = &H8 
 Const BIF_BROWSEFORCOMPUTER = &H1000 
 Const BIF_BROWSEFORPRINTER = &H2000 
 Const MAX_PATH = 260 

 Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" 
     (ByVal pidl As Long, ByVal pszPath As String) As Long 
 Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderA" 
     (lpBrowseInfo As BROWSEINFO) As Long 
 Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long) 
 Declare Function GetDesktopWindow Lib "user32" () As Long 


 Sub Initialize() 
   
 Dim session As New NotesSession 
 Dim db As NotesDatabase 
 Dim collection As NotesDocumentCollection 
 Dim doc As NotesDocument   
 Dim rtitem As Variant 
 Dim NotesItem As NotesItem 
   
 Dim bi As BROWSEINFO 
 Dim pidl As Long 
 Dim path As String 
 Dim pos As Integer 
   
 bi.hOwner = GetDesktopWindow() 
 bi.pidlRoot = 0& 
 bi.lpszTitle = "Select directory to save the attachments"
 bi.ulFlags = BIF_RETURNONLYFSDIRS 
 pidl = SHBrowseForFolder(bi) 
 path = Space$(MAX_PATH) 

 If SHGetPathFromIDList(ByVal pidl, ByVal path) Then 
 pos = InStr(path, Chr$(0)) 
 End If 

 Call CoTaskMemFree(pidl) 

   Set db = session.CurrentDatabase 
   Set collection = db.UnprocessedDocuments 
   Set doc = collection.GetFirstDocument() 
   
 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( Left(path, pos - 1) & "\" & o.Name  ) 
          End If         
          End ForAll 
     End If 
    Set doc = collection.GetNextDocument(doc) 
   Wend 

 End Sub 

				
 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