从Lotus Notes数据库导出数据

这是我多年前写的一个免费工具，用于将数据导出到Excel： 导出到Excel 2.0

另外，我编写了一些代码来从电子邮件中提取附件，而且这些代码可以适用于其他数据库

(Declarations) Dim sDir As String Dim s As NotesSession Dim w As NotesUIWorkspace Dim db As NotesDatabase Dim dc As NotesDocumentCollection Dim doc As NotesDocument Sub Initialize Set s = New NotesSession Set w = New NotesUIWorkspace Set db = s.CurrentDatabase Set dc = db.UnprocessedDocuments Set doc = dc.GetFirstDocument Dim rtItem As NotesRichTextItem Dim RTNames List As String Dim DOCNames List As String Dim itemCount As Integer Dim sDefaultFolder As String Dim x As Integer Dim vtDir As Variant Dim iCount As Integer Dim j As Integer Dim lngExportedCount As Long Dim attachmentObject As Variant x = Msgbox("This action will extract all attachments from the " & Cstr (dc.Count) & _ " document(s) you have selected, and place them into the folder of your choice." & _ Chr(10) & Chr(10) & "Would you like to continue?", 32 + 4, "Export Attachments") If x <> 6 Then Exit Sub sDefaultFolder = s.GetEnvironmentString ("LPP_ExportAttachments_DefaultFolder") If sDefaultFolder = "" Then sDefaultFolder = "F:" vtDir = w.SaveFileDialog( False, "Export attachments to which folder?", "All files|*.*", sDefaultFolder, "Choose Folder and Click Save") If Isempty(vtDir) Then Exit Sub sDir = Strleftback(vtDir(0), "\") Call s.SetEnvironmentVar ("LPP_ExportAttachments_DefaultFolder", sDir) While Not (doc Is Nothing) iCount = 0 itemCount = 0 lngExportedCount = 0 Erase RTNames Erase DocNames 'Scan all items in document Forall i In doc.Items If i.Type = RICHTEXT Then Set rtItem = doc.GetfirstItem(i.Name) If Not Isempty(rtItem.EmbeddedObjects) Then RTNames(itemCount) = Cstr(i.Name) itemCount = itemCount +1 End If End If End Forall For j = 0 To itemCount-1 Set rtItem = Nothing Set rtItem = doc.GetfirstItem(RTNames(j)) Forall Obj In rtItem.EmbeddedObjects If ( Obj.Type = EMBED_ATTACHMENT ) Then Call ExportAttachment(Obj) Call Obj.Remove Call doc.Save( False, True ) 'creates conflict doc if conflict exists End If End Forall Next 'Scan all items in document Forall i In doc.Items If i.Type = ATTACHMENT Then DOCNames(lngExportedCount) = i.Values(0) lngExportedCount = lngExportedCount + 1 End If End Forall For j% = 0 To lngExportedCount-1 Set attachmentObject = Nothing Set attachmentObject = doc.GetAttachment(DOCNames(j%)) Call ExportAttachment(attachmentObject) Call attachmentObject.Remove Call doc.Save( False, True ) 'creates conflict doc if conflict exists Next Set doc = dc.GetNextDocument(doc) Wend Msgbox "Export Complete.", 16, "Finished" End Sub Sub ExportAttachment(o As Variant) Dim sAttachmentName As String Dim sNum As String Dim sTemp As String sAttachmentName = sDir & "\" & o.Source While Not (Dir$(sAttachmentName, 0) = "") sNum = Right (Strleftback(sAttachmentName, "."), 2) If Isnumeric(sNum) Then sTemp = Strleftback(sAttachmentName, ".") sTemp = Left(sTemp, Len(sTemp) - 2) sAttachmentName = sTemp & Format$(Cint(sNum) + 1, "##00") & _ "." & Strrightback(sAttachmentName, ".") Else sAttachmentName = Strleftback(sAttachmentName, ".") & _ "01." & Strrightback(sAttachmentName, ".") End If Wend Print "Exporting " & sAttachmentName 'Save the file Call o.ExtractFile( sAttachmentName ) End Sub