从数据库中将附件提取到每个文档的单独文件夹中

Question

有一项任务要做 - 从 Lotus Notes DB 中提取数据，包括文档及其附件。这样做的目的是将其作为库放置并存储在 Sharepoint 上。

到目前为止，我已经成功创建了一个视图并将其数据导出到 Excel 中进行结构。

此外，我还查找了一些用于提取附件的代理示例。通过执行以下脚本，我成功导出了附件：

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

所以我现在遇到的问题是这些附件被保存到同一个文件夹中，这意味着我必须手动将它们放入库的正确文件夹中（数千个）。任何人都可以帮助我如何更改上面的代码，将附件保存到数据库中每个文档的单独文件夹中？

此外，由于某种原因，我无法找出下面的行导致弹出错误“对象变量未设置”：

sAttachmentName = sDir & "\" & o.Source

有人知道为什么它会导致失败并停止整个过程吗？

Answer 1

您需要使用 MkDir 语句创建目录并提取文件夹中的附件。大概写成这样：

MkDir sDir

Answer 2

您需要编写代码为每个文档创建一个新目录（确保检查该目录是否存在，最好确保每个目录都有唯一的名称）。

我编写了一个类似的工具，它将文档的所有字段以及附件和嵌入图像导出为 XML。可以将其设置为将每个文档分隔到其自己的目录中。 您可以通过下面的链接阅读有关它的更多信息，也许您可以从描述中获得一些想法。我使用文档的 UniversalID 来获取唯一的文件夹名称。

http://www.texasswede.com/websites/texasswede.nsf/Page/Notes%20XML%20Exporter