[AC-2007] Stockage dans Access du mail qui a été envoyé

Stockage dans Access du mail qui a été envoyé

Bonjour,
J'envoie des mails via un code du genre :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Dim O As Outlook.Application Dim M As Outlook.mailItem Set O = New Outlook.Application Set M = O.CreateItem(olMailItem) With M .BodyFormat = olFormatHTML .HTMLBody = msg .To = "destinataire@gmail.com" .Subject = "Toto du " & Now() .Display End With Set M = Nothing Set O = Nothing
Ca marche nickel, mais je voudrais pouvoir garder ds ma table access un lien vers ce mails, pour que d'un simple clic, on ouvre le mails ds les éléments envoyès de outlook, est-ce possible ?

Bonjour bartimeus35,

Alors oui c'est possible. Comment? C'est une bonne question. La meilleure façon de faire est de se servir du "ID" du mail, mais il n'est pas connu d'Access. Une manière de faire (plus simple), avec le code que vous avez montré dans votre post serait de se servir du ".Subject". Le gros défaut de cette solution est que si vous avez plusieurs ".Subject" identique ça ne fonctionnera pas. Le choix du mail sera aléatoire dans ceux ayant le même ".Subject".

Vous devrez conserver dans une table vos ".Subject" et à partir d'une liste ou un formulaire à votre choix le code suivant sur un bouton de commande:

Code:

1
2
3
4
5
6
7
8
9
Private Sub btnOuvrirOutlook_Click()
 
    If fuOutookIsClose Then
        MsgBox "Vous devez ouvrir Outlook!", vbCritical, "Outlook est fermé"
    Else
       OuvrirMail "LeNomDuCompteOutlook", "Sent", "Toto du 2023-03-07 10:25:30"
    End If
 
End Sub

La première partie test si Outlook est ouvert, ce qui est nécessaire pour la suite.
La deuxième partie appel la fonction "OuvrirMail" qui demande en argument le nom du compte Outlook étant le nom de votre compte, le "Sent" dans un Outlook français doit se nommer "Éléments envoyés" et le titre de votre mail.

Ensuite dans un module le code suivant:

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
Option Compare Database
Option Explicit
 
'============================================================Public function===============================================================
Public Function fuOutookIsClose() As Boolean
 
    Dim oOutlook As Object
 
    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0
 
    If oOutlook Is Nothing Then
        fuOutookIsClose = True
    Else
        Set oOutlook = Nothing
    End If
End Function
 
'============================================================Public sub===============================================================
 
Public Sub OuvrirMail(sCompte As String, sDossier As String, sTitre As String)
On Error GoTo gestion_err
 
    Dim oOutlook As Outlook.Application
    Dim oNameSpace As Outlook.NameSpace
    Dim oFolder As Outlook.Folder
    Dim oAccount As Outlook.Account
 
    Set oOutlook = New Outlook.Application
    Set oNameSpace = oOutlook.GetNamespace("MAPI")
    Set oFolder = oNameSpace.Folders(sCompte)
    SearchAndOpenMail oFolder, sTitre, sDossier
    Set oOutlook = Nothing
    Set oNameSpace = Nothing
    Set oFolder = Nothing
 
Sortie:
Exit Sub
gestion_err:
        fuErr_Handler "OuvrirMail"
        Resume Sortie
End Sub
'=============================================================Private sub============================================================
 
Private Sub SearchAndOpenMail(ByVal Fld As Outlook.Folder, sTitre As String, sDossier As String)
On Error GoTo gestion_err
 
    Dim oLmail As Variant
    Dim oSousDossier As Outlook.Folder
 
    For Each oSousDossier In Fld.Folders
        If oSousDossier.DefaultItemType = 0 And oSousDossier = sDossier Then
        For Each oLmail In oSousDossier.Items
        If oLmail.Subject = sTitre Then
            oLmail.Display
            GoTo Sortie
        End If
        Next oLmail
        End If
        SearchAndOpenMail oSousDossier, sTitre, sDossier
    Next oSousDossier
 
Sortie:
    Set oLmail = Nothing
    Set oSousDossier = Nothing
Exit Sub
gestion_err:
        fuErr_Handler "SearchAndOpenMail"
        Resume Sortie
End Sub

Ligne 5 est la fonction qui test si Outlook est ouvert, ligne 22 sub public pour lancer la procédure et ligne 46 sub privé pour parcourir le répertoire et les sous-répertoires du répertoire et les mails et ouvrir celui désiré.
Ensuit si vous désirez garder la gestion d'erreur tel quel un autre module comme suit:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Option Compare Database
Option Explicit
 
Public Const g_ProjectName = "Manipulation Outlook"
 
Public Sub fuErr_Handler(Optional strProcName As String)
 
    Dim strMsg As String
    strMsg = "Une erreur inatendue [" & Err.Number & "] est arrivée."
 
    If Nz(strProcName, "") <> "" Then
        strMsg = strMsg & vbNewLine & "Dans la procédure '" & strProcName & "'"
    End If
    strMsg = strMsg & vbNewLine & vbNewLine & Err.Description
    MsgBox strMsg, vbOKOnly + vbExclamation, g_ProjectName & ": Erreur inatendue"
 
End Sub

Naturellement la référence à Outllook XX ObjectLibrary doit être sélectionnée.

Bonne journée

3 pièce(s) jointe(s)

J'ai un souci, j'ai ça de paramétré ds outlook:

Pièce jointe 635484
J'ai ça ds mon code

Pièce jointe 635485
Et quand j'exécute, ce me sort :
Pièce jointe 635486
il sort en erreur à l'exécution de

Code:

Set oFolder = oNameSpace.Folders(sCompte)

1 pièce(s) jointe(s)

Bonjour bartimeus35,

Le nom du compte est ici, dans l'onglet fichier de Outlook:
Pièce jointe 635501

Bonne journée

1 pièce(s) jointe(s)

Je n'ai pAs ces données dans le menu Fichier.
Je suis sous Outlook 2007.
Si je vais dans outils > Paramètres Du compte, j'ai ça :
Pièce jointe 635502

Bonjour bartimeus35,

Voici une routine qui vous donnera le nom (dans la fenêtre d'exécution) de vos comptes Outlook:

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
Private Sub ListCompte()
On Error GoTo gestion_err
 
    Dim oOutlook As Outlook.Application
    Dim oNameSpace As Outlook.NameSpace
    Dim oFolder As Outlook.Folder
    Dim oAccount As Outlook.Account
 
    Set oOutlook = New Outlook.Application
    Set oNameSpace = oOutlook.GetNamespace("MAPI")
 
    For Each oAccount In oOutlook.Session.Accounts
        Debug.Print oAccount.DisplayName
    Next oAccount
    Set oOutlook = Nothing
    Set oNameSpace = Nothing
    Set oFolder = Nothing
 
Sortie:
Exit Sub
gestion_err:
        fuErr_Handler "suRecupOutlook"
        Resume Sortie
 
End Sub

Bonne journée

Bonjour,
Je viens d’exécuter le code qui me donne les noms de mes comptes Outlook, et j'obtiens bien un seul compte francois.xxx@live.fr, et c'est ce que je mets depuis le début .
Étrange, je dois, avoir mal paramétré mon je suppose.
Je vais creuser ....
Merci en tout cas,
Coirdialement,