J'ai créé un bouton qui lance le LotusScript et pour vous amis du forum le même script traduit en français (IBM c'est bien mais c'est tout en anglais ça gave à force)
- Code : Tout sélectionner
Sub Click(Source As Button)
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) = "Base Notes courante"
choices(1) = "Autre base Notes locale"
choices(2) = "Autre Base Notes sur le serveur"
' get source database
sourceDbType = w.Prompt(PROMPT_OKCANCELLIST, "Selection de la base source", _
"Selectionner la base Notes que vous voulez copier:", _
choices(0), choices)
If sourceDbType = "" Then
Messagebox "Opération annulée"
Exit Sub
End If
If sourceDbType = choices(0) Then
Set sourceDb = s.CurrentDatabase
Else
If sourceDbType = choices(1) Then
sourceDbServer = ""
sourceDbNameReturn = w.OpenFileDialog(False, _
"Selection de la base source", "*.nsf", _
s.GetEnvironmentString("Directory", True))
If Isempty(sourceDbNameReturn) Then 'Means they hit Cancel
Msgbox("Opération annulée : impossible de continuer sans un nom de fichier.")
Exit Sub
End If
sourceDbName=SourceDbNameReturn(0)
Else
sourceDbServer = Inputbox("Entrer le nom du serveur Domino")
sourceDbName = Inputbox("Entrer le nom de fichier de la base (expl : mail/nomdelabase.nsf)")
If sourceDbName = "" Then
Msgbox("Opération annulée : impossible de continuer sans un nom de fichier.")
Exit Sub
End If
End If
If Not (sourceDb.Open(sourceDbServer, sourceDbName)) Then
Msgbox("Impossible de trouver ou ouvrir le fichier: " + sourceDbName)
Exit Sub
End If
End If
' get destination database
destDbType = w.Prompt(PROMPT_OKCANCELLIST, "Selection de la base cible", _
"Selectionner la base Notes où vous voulez coller les dossiers et documents", _
choices(1), choices)
If destDbType = "" Then
Messagebox "Opération annulée"
Exit Sub
End If
If destDbType = choices(0) Then
Set destDb = s.CurrentDatabase
Else
If destDbType = choices(1) Then
destDbServer = ""
destDbNameReturn = w.OpenFileDialog(False, _
"Selection de la base source", "*.nsf", _
s.GetEnvironmentString("Directory", True))
If Isempty(destDbNameReturn) Then 'Means they hit Cancel
Msgbox("Opération annulée : impossible de continuer sans un nom de fichier.")
Exit Sub
End If
destDbName=destDbNameReturn(0)
Else
destDbServer = Inputbox("Entrer le nom du serveur Domino")
destDbName = Inputbox("Entrer le nom de fichier de la base (expl : mail/nomdelabase.nsf)")
If destDbName = "" Then
Msgbox("Opération annulée : impossible de continuer sans un nom de fichier.")
Exit Sub
End If
End If
If Not (destDb.Open(destDbServer,destDbName)) Then
Msgbox("Impossible de trouver ou ouvrir le fichier: " + destDbName)
Exit Sub
End If
End If
If destdb.server=sourcedb.server And destdb.filename=sourcedb.filename And destdb.filepath=sourcedb.filepath Then
Msgbox("La base source et la Base de destination ne peuvent pas être identique")
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("Impossible de créer un dossier dans la nouvelle Base.")
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("Les documents ont été copié. Fermez et réouvrez la base de destination (si elle est ouverte) pour que la vue soit actualisée.")
End Sub