VBA - LOTUS NotesDocument.?
Bonjour,
voila je dois extraire tous les mails contenu dans Lotus Notes.
J'ai réussi à adapter mon grâce à ceci:
http://www.developpez.net/forums/d60...c-lotus-notes/
Cependant, ce code permet de déplacer des mails dans d'autres dossiers de Lotus. Alors que je voudrai les extraire de Lotus (si possible au format PDF) vers mon bureau.
Voici donc le code:
Code:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
|
Option Explicit
Public view As Object 'NOTESVIEW
Public doc As NotesDocument
Public session As New NotesSession
Public dir As NotesDbDirectory
Public db As NotesDatabase
Const RepDest = "C:\ExtractionMail\"
Private Sub Form_Load()
'Déclaration Variable
Dim i
Dim j As Integer
Dim k As Integer
Dim n As Integer
Dim Classer As Boolean
'Initialisation de la session avec mot de passe
session.Initialize ("MonMDP")
'Connexion au serveur
Set dir = session.GetDbDirectory("Serveur")
'Connexion au fichier
Set db = dir.OpenDatabase("monfichier.nsf")
'Connexion sur la vue de boîte de réception
Set view = db.GetView("($INBOX)")
'Se placer sur le premier document
Set doc = view.GetFirstDocument
Classer = False
'Tant qu'il y a un document
Do While Not doc Is Nothing
'On regarde l'expéditeur
If InStr(doc.GetFirstItem("From").Text, "toto@titi.fr") Then
'Boite de dialogue pour voir les infos
Msgbox "Expéditeur : " & doc.GetFirstItem("From").Text
msgbox "Date : " & doc.GetFirstItem("PostedDate").Text
msgbox "Sujet : " & Replace(doc.GetFirstItem("Subject").Text, vbCr, "")
msgbox "Corps du message : " & Replace(doc.GetFirstItem("Body")
.Text, vbCr, "")
'On classe le mail
moveToFolder db, doc, "Perso"
Classer = True
End If
If Classer = True Then
'Si on vient de classer un mail, on reprend la lecture depuis le début
'Comme on a classer le mail sélectionné, l'objet doc est dans les choux
Set doc = view.GetFirstDocument
'Si c'est vide on quitte la boucle
If doc Is Nothing Then Exit Do
Classer = False
Else
'Sinon on passe au mail suivant
Set doc = view.GetNextDocument(doc)
End If
Loop
End
End Sub
Function moveToFolder(dbMailbox As NotesDatabase, docMailbox As NotesDocument, folderName As String) As Boolean
Dim docMailBoxCopy As NotesDocument
On Error GoTo handleError
Set docMailBoxCopy = docMailbox.CopyToDatabase(dbMailbox)
docMailBoxCopy.PutInFolder folderName, True
docMailbox.Remove True
On Error GoTo 0
moveToFolder = True
Exit Function
handleError:
MsgBox "Error # " & Err & " : " & Error$ & " - line " & Erl, 16, "DEMOA Notes Error - moveToFolder"
End Function |
Il faut modifier la fonction moveToFolder je pense,
Code:
docMailBoxCopy.PutInFolder folderName, True
mais je ne trouve pas la fonction qui permettrai de déplacer vers mon bureau.
Si quelqu'un connait la solution.
Merci !!