Exporter partie de corps de mail depuis Outlook vers Access ?

Version imprimable

04/04/2013, 22h26
Dixies

Exporter partie de corps de mail depuis Outlook vers Access ?

Bonsoir,

Je reçois quotidiennement un mail dans lequel une seule valeur numérique dans le corps du mail m'intéresse.
J'ai mis au point un bout de code dans Outlook pour isoler cette valeur numérique.

Question : peut-on, à l'ouverture d'Outlook (via une macro autoexécutable) exporter cette valeur vers une table Access ? En l'ajoutant dans la table bien sûr.

Merci d'avance.

1 pièce(s) jointe(s)

Bonjour,

J'ai un petit peu avancé mais à défault d'exporter vers Access ceci exporte vers un fichier Txt :

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
Sub InfoSelection()
 
'Déclaration des Objets et variables
    Dim MonApply As Outlook.Application
    Dim MonMail As Outlook.MailItem
    Dim MonNSpace As Outlook.NameSpace
    Dim FldDossier As Outlook.Folder
    Dim strInfos As String
    Dim i As Long
 
    'Instance des Objets
    Set MonApply = Outlook.Application    'Application Outlook
    Set MonNSpace = MonApply.GetNamespace("MAPI")    'Banque MAPI
    Set FldDossier = MonNSpace.GetDefaultFolder(olFolderInbox)    'Dossier boîte de réception
    'Initialisation de la chaîne de caractères
    strInfos = ""
    'Boucle afin de parcourir l'ensemble des E-mails présents dans le dossier Boîte de réception
    For i = 1 To FldDossier.Items.Count
        'instancie le mail suivant la valeur de la boucle
        Set MonMail = FldDossier.Items(i)
        'Test sur l'expéditeur
        If MonMail.SenderEmailAddress = "support@prix-carburants.fr" Then
            'Récupère les diverses informations du Mail
            With MonMail
                strInfos = "Expéditeur : " & .SenderEmailAddress
                strInfos = strInfos & vbCr '& "Destinataire(s) : " & .To
                strInfos = strInfos & vbCr & "Date de réception : " & .ReceivedTime
                strInfos = strInfos & vbCr & "Prix du Gasoil : " & Mid(MonMail.Body, 230, 5) & " €uros"
 
            End With
            'Affichage du résultat
            MsgBox strInfos
 
            Dim oFSO As Scripting.FileSystemObject
            Dim oTXT As Scripting.TextStream
 
            'Instancie les Objets pour création fichier Texte
            Set oFSO = New Scripting.FileSystemObject
            Set oTXT = oFSO.CreateTextFile("F:\Mes documents\Test.txt", True)
 
            'Accès au nouveau fichier texte
            With oTXT
                'Ajout d'une ligne et écriture
                .WriteLine MonMail.ReceivedTime & " " & Mid(MonMail.Body, 230, 5)
                'Fermeture du fichier
                .Close
 
            End With
 
            'Vide les instances
            Set oTXT = Nothing
            Set oFSO = Nothing
 
        End If
 
    Next i
 
    'Vide des instances
    Set MonApply = Nothing
    Set MonNSpace = Nothing
    Set FldDossier = Nothing
    Set MonMail = Nothing
 
End Sub

Toutefois j'ai un souci avec ce code car à chaque :

Code:

1
2
 'Ajout d'une ligne et écriture
      .WriteLine MonMail.ReceivedTime & " " & Mid(MonMail.Body, 230, 5)

il n'ajoute pas de ligne au fichier mais remplace la ligne existante (celle d'hier ...) par celle d'aujourd'hui. Or je voudrais avoir une ligne par jour .... :aie:

Sinon je ne désespère pas de trouver avec votre aide la solution pour exporter directement vers Access.

Merci et bonne journée.

Bonjour,

Il faut pas créer le fichier à chaque fois mais l'ouvrir en forappending s'il existe
Voici un exemple à adapter

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub testvbecr()
Dim GestionFichier As New Scripting.FileSystemObject
    Dim FichierTexte As Scripting.TextStream
       If GestionFichier.FileExists("C:\testvbecr.txt") = False Then 'Test existence du fichier
       Set FichierTexte = GestionFichier.CreateTextFile("C:\testvbecr.txt")
    Else 'Ouverture avec écriture à la fin du fichier
     Set FichierTexte = GestionFichier.OpenTextFile("C:\testvbecr.txt", ForAppending)
    End If
     FichierTexte.WriteLine ("test")
    FichierTexte.Close
    Set GestionFichier = Nothing
 
End Sub

Ah ben oui, c'est nettement mieux comme ça !!!:ccool:.

Bonjour carden et merci pour l'info.
J'ai donc appliqué la modif comme suit :

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
...
    For i = 1 To FldDossier.Items.Count
        'instancie le mail suivant la valeur de la boucle
        Set MonMail = FldDossier.Items(i)
        'Test sur le sujet si égale à Invitation
        If MonMail.SenderEmailAddress = "support@prix-carburants.fr" Then
            'Récupère les diverses informations du Mail ayant pour sujet Invitation
            With MonMail
                strInfos = "Expéditeur : " & .SenderEmailAddress
                strInfos = strInfos & vbCr '& "Destinataire(s) : " & .To
                strInfos = strInfos & vbCr & "Date de réception : " & .ReceivedTime
                strInfos = strInfos & vbCr & "Prix du Gasoil : " & Mid(MonMail.Body, 230, 5) & " €uros"
 
            End With
            'Affichage du résultat
            MsgBox strInfos
 
            Dim oFSO As Scripting.FileSystemObject
            Dim oTXT As Scripting.TextStream
 
            'Instancie les Objets pour création fichier Texte
            Set oFSO = New Scripting.FileSystemObject
 
            If oFSO.FileExists("F:\Mes documents\Test.txt") = False Then 'Test existence du fichier
                Set oTXT = oFSO.CreateTextFile("F:\Mes documents\Test.txt")
                Else 'Ouverture avec écriture à la fin du fichier
                Set oTXT = oFSO.OpenTextFile("F:\Mes documents\Test.txt", ForAppending)
            End If
 
            'Accès au nouveau fichier texte
            With oTXT
                'Ajout d'une ligne et écriture
                .WriteLine MonMail.ReceivedTime & " " & Mid(MonMail.Body, 230, 5)
                'Fermeture du fichier
                .Close
 
            End With
 
            'Vide les instances
            Set oTXT = Nothing
            Set oFSO = Nothing
 
        End If
 
    Next i
...

et ça marche.

A présent, reste à faire la même chose mais direct dans une table Access.
Une idée ?

Je ne manquerai pas de vous tenir au courant de mes recherches.

Merci encore bonne journée.

05/04/2013, 12h19
carden752

Bonjour,

Il faut regarder du côté de la FAQ VBA Access, peut-être en DAO avec une requête Action
http://access.developpez.com/faq/?page=SQL#qryActions

C'est bon !!!

Sur ton idée j'ai fais ceci :

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
Sub InfoSelection()
 
    'Déclaration des Objets et variables
    Dim MonApply As Outlook.Application
    Dim MonMail As Outlook.MailItem
    Dim MonNSpace As Outlook.NameSpace
    Dim FldDossier As Outlook.Folder
    Dim strInfos As String
    Dim VarVal As Double
    Dim i As Long
    Dim db As DAO.Database
 
    'Instance des Objets
    Set MonApply = Outlook.Application    'Application Outlook
    Set MonNSpace = MonApply.GetNamespace("MAPI")    'Banque MAPI
    Set FldDossier = MonNSpace.GetDefaultFolder(olFolderInbox)    'Dossier boîte de réception
 
    'Initialisation de la chaîne de caractères
    strInfos = ""
 
    'Boucle afin de parcourir l'ensemble des E-mails présents dans le dossier Boîte de réception
    For i = 1 To FldDossier.Items.Count
 
        'instancie le mail suivant la valeur de la boucle
        Set MonMail = FldDossier.Items(i)
 
        'Test sur le sujet si égale à Invitation
        If MonMail.SenderEmailAddress = "support@prix-carburants.fr" Then
 
            'Récupère les diverses informations du Mail ayant pour sujet Invitation
            With MonMail
                strInfos = "Expéditeur : " & .SenderEmailAddress
                strInfos = strInfos & vbCr '& "Destinataire(s) : " & .To
                strInfos = strInfos & vbCr & "Date de réception : " & .ReceivedTime
                strInfos = strInfos & vbCr & "Prix du Gasoil : " & Mid(MonMail.Body, 230, 5) & " €uros"
                VarVal = Val(Mid(MonMail.Body, 230, 5))
            End With
 
            'Accès au nouveau fichier Access
            Set db = DBEngine.OpenDatabase("F:\Mes documents\Prix Gasoil.accdb")
 
            ' Exécution de la requête
            db.Execute "Insert into T_PrixGasoil (IdDate,Prix) Values ('" & MonMail.ReceivedTime & "','" & VarVal & "')"
            Debug.Print "Records Affected = " & db.RecordsAffected
            db.Close
            MonMail.Delete
 
        End If
 
    Next i
 
    'Vide des instances
    Set MonApply = Nothing
    Set MonNSpace = Nothing
    Set FldDossier = Nothing
    Set MonMail = Nothing
 
End Sub

Et ça fonctionne comme je la souhaite.
Maintenant comment executer automatiquement ce code ?
Avec ceci ?: http://outlook.developpez.com/faq/?p...e_nouveau_mail

Code:

... .EntryId

Je commence à ne plus y voir trés clair donc où placer cette fonction dans le code ?

Merci d'avance.

07/04/2013, 15h38
Dixies

Bonjour,

J'ai trouvé comment automatiser mon code. Voir ici :http://dolphy35.developpez.com/artic...k/vba/#LV-A-10

Merci carden, merci le forum encore une fois ...:ccool:

A bientôt.
28/08/2015, 13h01
OUMAR DIAW

Code Integrale

Salu les pro je peux avoir le code Integrale svp jen est vrema besoin vous pouvez me l'envoyer dans oumar.diaw@uadb.edu.sn
Svpppppppppppppppppppppppppp