0

有一项任务要做 - 从 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

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

谢谢， 拉法尔

4

2 回答 2

0

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

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

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

在此处输入图像描述

于 2013-11-18T14:45:28.643 回答
0

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

MkDir sDir
于 2013-11-14T11:32:05.990 回答