So sollte es gehen..
Dim s As New NotesSession
Dim w As New NotesUIWorkspace
Dim destDb As New NotesDatabase("","")
Dim sourceDb As New NotesDatabase("","")
Dim AllDocs As NotesDocumentCollection
Dim AllDocsView As NotesView
Dim sourceDoc As NotesDocument
Dim destDoc As NotesDocument
Dim tempDoc As NotesDocument
Dim docCount As Variant
Dim current As Variant
Dim choices (0 To 2) As Variant
choices(0) = "Current Database"
choices(1) = "Local Database"
choices(2) = "Database on Server"
' get source database
sourceDbType = w.Prompt(PROMPT_OKCANCELLIST, "Select Database Location", _
"Select the location of the database you would like to copy from:", _
choices(0), choices)
If sourceDbType = "" Then
Messagebox "Operation cancelled"
Exit Sub
End If
If sourceDbType = choices(0) Then
Set sourceDb = s.CurrentDatabase
Else
If sourceDbType = choices(1) Then
sourceDbServer = ""
sourceDbNameReturn = w.OpenFileDialog(False, _
"Select the database you would like to copy from", "*.nsf", _
s.GetEnvironmentString("Directory", True))
If Isempty(sourceDbNameReturn) Then 'Means they hit Cancel
Msgbox("Operation cancelled: Unable to continue without a filename.")
Exit Sub
End If
sourceDbName=SourceDbNameReturn(0)
Else
sourceDbServer = Inputbox("Enter the name of the Domino server")
sourceDbName = Inputbox("Enter the filename of the database relative to the server data directory")
If sourceDbName = "" Then
Msgbox("Operation cancelled: Unable to continue without a filename.")
Exit Sub
End If
End If
If Not (sourceDb.Open(sourceDbServer, sourceDbName)) Then
Msgbox("Unable to find/open file: " + sourceDbName)
Exit Sub
End If
End If
' get destination database
destDbType = w.Prompt(PROMPT_OKCANCELLIST, "Destination Database", _
"Select the location of the database you would like to copy documents/folders to", _
choices(1), choices)
If destDbType = "" Then
Messagebox "Operation cancelled"
Exit Sub
End If
If destDbType = choices(0) Then
Set destDb = s.CurrentDatabase
Else
If destDbType = choices(1) Then
destDbServer = ""
destDbNameReturn = w.OpenFileDialog(False, _
"Please select the database you would like to copy from", "*.nsf", _
s.GetEnvironmentString("Directory", True))
If Isempty(destDbNameReturn) Then 'Means they hit Cancel
Msgbox("Operation cancelled: Unable to continue without a filename.")
Exit Sub
End If
destDbName=destDbNameReturn(0)
Else
destDbServer = Inputbox("Enter the name of the Domino server")
destDbName = Inputbox("Enter the filename of the database relative to the server data directory")
If destDbName = "" Then
Msgbox("Operation cancelled: Unable to continue without a filename.")
Exit Sub
End If
End If
If Not (destDb.Open(destDbServer,destDbName)) Then
Msgbox("Unable to find/open file: " + destDbName)
Exit Sub
End If
End If
If destdb.server=sourcedb.server And destdb.filename=sourcedb.filename And destdb.filepath=sourcedb.filepath Then
Msgbox("Source and Destination database should not be the same database")
Exit Sub
End If
' Build collection of all documents in source database using selection
' formula similar to that used in the Mail templates All Documents view
AllDocsSelect = "@IsNotMember(""A""; ExcludeFromView) & IsMailStationery != 1" + _
"& Form != ""Group"" & Form != ""Person"""
Set AllDocs = sourceDb.Search(AllDocsSelect, Nothing, 0)
' display progress
docCount = AllDocs.Count
current = 0
Print Cstr(Round(current / docCount * 100, 0)) + "% copied"
' step through each folder in source database except system folders other than Inbox
Forall folder In sourceDb.Views
If folder.IsFolder And (Instr(1, folder.Name, "(", 0)<>1 Or folder.Name="($Inbox)") Then
' The following code ensures that folders with no docs in them still get copied
' so that any folder design customizations are kept
Set destFolder = destDb.GetView(folder.Name)
If destFolder Is Nothing Then
Set sourceFolder = sourceDb.GetDocumentByUNID(folder.UniversalID)
Call sourceFolder.CopyToDatabase(destDb)
Set destFolder = destDb.GetView(folder.Name)
If destFolder Is Nothing Then
Msgbox("Unable to create folder in new database.")
Exit Sub
End If
End If
' cycle through each doc in the current folder
Set sourceDoc = folder.GetFirstDocument
While Not (sourceDoc Is Nothing)
Set destDoc = sourceDoc.CopyToDatabase(destDb)
' copy each document to the same folder in the destination database
Call destDoc.PutInFolder(folder.Name, True)
' remove document from the collection of docs built from source db all docs view
Set tempDoc = AllDocs.GetDocument(sourceDoc)
Set sourceDoc = folder.GetNextDocument(tempDoc)
Call AllDocs.DeleteDocument(tempDoc) 'remove from collection
' display progress
current = current + 1
Print Cstr(Round(current / docCount * 100, 0)) + "% copied"
Wend
End If
End Forall
' docs remaining in collection are not in any folder - copy these to dest. db
Set sourceDoc = AllDocs.GetFirstDocument
While Not (sourceDoc Is Nothing)
Call sourceDoc.CopyToDatabase(destDb)
' display progress
current = current + 1
Print Cstr(Round(current / docCount * 100, 0)) + "% copied"
Set sourceDoc = AllDocs.GetNextDocument(sourceDoc)
Wend
'done
Msgbox("Documents have been copied. Close and reopen the destination file (if it is open) so that it can be refreshed.")
