Manipuler mes fichiers .msg dans outlook et access

Bonjour,

Je souhaite manipuler les courriels OUTLOOK de la manière suivante :

1) procéder à leur copier/coller dans un répertoire de mon disque dur et en procédant à leur renommage pour indiquer la date de réception et l'émetteur du courriel (çà, pas de difficulté c'est de la manipulation de fichiers expliquée dans la FAQ et les tutos) et récupère le chemin des mails sous cette forme :

Code:

1
2
3
 
' adresse courriel récupérée
C:\Users\pythe\AppData\Local\Temp\1*votreinvitation.msg, C:\Users\pythe\AppData\Local\Temp\1*votreconfirmation.msg

Pour traiter ces courriels, et faire mes copier/coller, j'utilise la fonction SPLIT avec la "," comme critère de découpe.

2) modifier le mail dans "OUTLOOK" pour qu'une fois "transféré" dans le répertoire précité, le mail dans OUTLOOK se voit complété de la mention "- transféré" dans son objet et passe en "catégorie rouge" (cela me permet visuellement de voir très rapidement dans OUTLOOK les mails traités des autres) (c'est là où je sèche :aie:).

En effet, j'avais un vieux code qui fonctionnait très bien par système "drag/drop" sur un champs memo

Pour faire simple, j'allais dans OUTLOOK et sélectionnais les courriels que je déposais dans un champ MEMO de mon formulaire :

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
 
On Error GoTo err:
If Forms!Menu!Texte105 = "local" Then
 
If Nz(EmailMemo, "") <> "" Then EmailMemo = ""
 
    'I got the guts of this sub from Remou on tek-tips.com. S/he told me I can drag and drop an
    'email to a memo field, then gave me the object control code to save the file.
    Dim olApp As outlook.Application
    Dim olExp As outlook.Explorer
    Dim olSel As outlook.Selection
    Dim I, intCounter, intResponse As Integer
    Dim strFilename, strSQL, strFolderPath, strPathAndFile, strMsg As String
    Dim fs As Object
    Dim fsFolder As Object
    Dim blnFolderExists, blnFileExists As Boolean
 
 
    strMsg = "ATTENTION. Vous mettez en oeuvre le drag and drop d'e-mail. Vérifiez tout ..." & vbCr & vbCr
    strMsg = strMsg & "Si vous voulez continuer, alors cliquez sur OUI. "
    strMsg = strMsg & "Si vous avez un doute ou si vous voulez arrêter, "
    strMsg = strMsg & "Cliquez sur NON." & vbCr & vbCr
    strMsg = strMsg & "Voulez-vous vraiment ajouter un E-mail à votre dossier COURRIER ?"
    intResponse = MsgBox(strMsg, vbYesNo)
    If intResponse = 7 Then 'No
        Cancel = True
        Exit Sub
    End If
 
 
    Set fsFolder = CreateObject("Scripting.FileSystemObject")
    strFolderPath = Forms!consultation_dossier!Texte101 & "\" & Forms!consultation_dossier!N°dossier_gestion & " " & Forms!consultation_dossier!Pour & " vs " & Forms!consultation_dossier!Contre & "\" & Forms!consultation_dossier!N°dossier_gestion & " courriers" ' ici c'est le répertoire courrier où les courriels renommés seront placés
    If fsFolder.FolderExists(strFolderPath) = False Then
        fsFolder.CreateFolder (strFolderPath)
    End If
 
    Dim x, y As String
 
'ici commençait le traitement du courriel dans OUTLOOK pour y ajouter la mention "transféré"                   
 
        Set olApp = GetObject(, "Outlook.Application")  'First argument is blank to return the currently
                                                        'active Outlook object, otherwise runtime fails
        Set olExp = olApp.ActiveExplorer
        Set olSel = olExp.Selection
        For I = 1 To olSel.Count
            Dim oItem As Object
                Dim oMailItem As outlook.MailItem
                Set oItem = olSel.Item(I)
                Set oMailItem = oItem
                oMailItem.subject = oMailItem.subject & " - transféré"
                oMailItem.Categories = "rouge"
        oMailItem.Save
 
 
    strPathAndFile = strFolderPath & "\" & Format(olSel.Item(I).ReceivedTime, "yyyymmdd") & " " & Format(olSel.Item(I).ReceivedTime, "hhmmss") & " recu de " & olSel.Item(I).SenderEmailAddress & ".msg" 'ici on copiait le fichier .msg dans le répertoire courrier en y adjoignant des infos
            olSel.Item(I).SaveAs strPathAndFile, olMSG
        Next
 
 
 
 
 
    Cancel = True   'To roll back changes caused by the drop.
   Me![EmailLocation] = strPathAndFile
    Me.EmailMemo = "EMAIL attaché au dosier avec succès. Déposez un nouveau mail."
 
    Set fsFolder = Nothing
    Set fs = Nothing
    Set olSel = Nothing
    Set olExp = Nothing
    Set olApp = Nothing
Else
MsgBox "Vous ne pouvez pas utiliser cette fonction en mode extérieur"
Exit Sub
End If
err:
Select Case err:
Case 0
On Error Resume Next
Case 76
EmailMemo = ""
MsgBox "Le dossier de destination n'existe pas. Le transfert n'a pas eu lieu"
Case Else
MsgBox err.Number & " et " & err.Description
Exit Sub
End Select

Comme je n'utilise plus de champs MEMO mais que je récupère directement le chemin des fichiers .msg (ce n'est peut être pas la bonne piste pour gérer mon 2):calim2: ), je ne vois pas comment adapter cette portion de code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
 
        Set olApp = GetObject(, "Outlook.Application")  'First argument is blank to return the currently
                                                        'active Outlook object, otherwise runtime fails
        Set olExp = olApp.ActiveExplorer
        Set olSel = olExp.Selection
        For I = 1 To olSel.Count
            Dim oItem As Object
                Dim oMailItem As outlook.MailItem
                Set oItem = olSel.Item(I)
                Set oMailItem = oItem
                oMailItem.subject = oMailItem.subject & " - transféré"
                oMailItem.Categories = "rouge"
        oMailItem.Save

J'espère avoir été clair.

Merci pour votre aide