IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Contribuez Discussion :

Automatiser le transfert d'un mail


Sujet :

Contribuez

  1. #1
    Membre chevronné Avatar de curt
    Homme Profil pro
    Ingénieur Etudes
    Inscrit en
    mars 2006
    Messages
    1 469
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations professionnelles :
    Activité : Ingénieur Etudes
    Secteur : Bâtiment Travaux Publics

    Informations forums :
    Inscription : mars 2006
    Messages : 1 469
    Points : 2 245
    Points
    2 245
    Par défaut Automatiser le transfert d'un mail
    Bonjour à tous,

    au préalable, ceci est ma première contribution alors soyez tolérant svp - Elle répond à la demande du forum Excel https://www.developpez.net/forums/d1...xcel-cvtheque/
    Ensuite, je me suis largement inspiré (et réutilisé) des bouts de procédures créés par d'autres personnes sur de nombreux sites - Qu'ils en soient ici remerciés.

    Que réalise cette contribution :
    1. A chaque lancement d'Outlook, les mails non-lus sont recopiés dans un dossier dont le nom est la date et l'heure de réception. On y retrouve :
      - Le mail au format .msg
      - Le mail au format .txt
      - Les pièces jointes

    Le mail n'est pas traité dans Outlook et reste dans son état de non-lu (sauf si on valide 3 lignes dans le code).
    Le code est suffisamment commenté - mais n'hésitez pas à me rapporter tous bugs, critiques, commentaires et, qui sait, des "petits pouces en l'air !!!"

    Le Code à intégrer dans Outlook est le suivant :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    'Références à activer :
    'Microsoft ActiveX Data Objects 6.1 Library
    '------------------------------------------
    Option Explicit
     
    Const olFolderInbox As Integer = 6
    '~~> DOSSIER DE DESTINATION
    Const AttachmentPath As String = "R:\Downloads\Outlook\"
     
    Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     
        OutlookVersExcel
     
    End Sub
     
    Private Sub Application_Startup()
     
        OutlookVersExcel
     
    End Sub
     
    Sub OutlookVersExcel()
     
    On Error GoTo Erreur
     
    Dim oOlAp As Object, oOlns As Object, oOlInb As Object
    Dim oOlItm As Object, oOlAtch As Object
     
    '~~> Nouveau fichier qui sera créé à partir du amil (Fichier .txt)
    Dim NewFileName As String
    Dim Mail As String, jour As String
     
    '~~> Variables Outlook pour les Emails
    Dim eSender As String       'email de l'expéditeur
    Dim dtRecvd As Variant      'Date de réception
    Dim dtSent As Variant       'Date d'envoi
    Dim eSenderName As String   'Nom de l'expéditeur
    Dim EntryID As String       'ID de l'email
    Dim sSubj As String         'Objet de l'email
    Dim sMsg As String          'Message
    Dim sEmail As String        'Nom du fichier .msg qui sera créé et sauvegardé
    Dim NewFolder As Variant    'Dossier créé pour stocker le mail en arrivée
     
    '~~> Variables pour la connexione et le transfert vers Excel
    Dim Source As ADODB.Connection
    Dim Rst As ADODB.Recordset
    Dim ADOCommand As ADODB.Command
    Dim FichierExcel As String, FeuilleExcel As String
    Dim SQLStr As String    'Requête pour insérer les données Outlook dans la feuille Excel
    Dim LastRow As Integer  'Dernière ligne de la feuille Excel
    Dim PJ As String        'Présence de pièce(s) jointe(s) dans l'email
     
    Dim Fld As ADODB.Field
     
        FichierExcel = AttachmentPath & "Outlook.xlsm"  'Classeur Excel dans lequel on va lister les emails
        FeuilleExcel = "Feuil1" 'Nom de la feuille Excel du classeur décrit ci-dessus
     
        '~~> Connexion au classeur Excel
        Set Source = New ADODB.Connection
        With Source
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                & FichierExcel & ";Extended Properties=""Excel 12.0;HDR=NO;"""   'HDR=YES > Première ligne Entête
            .Open
     
            'Recherche de la dernière ligne de la feuille Excel
            SQLStr = "SELECT * FROM [Feuil1$];"
            Set Rst = New ADODB.Recordset
            Rst.Open SQLStr, Source, adOpenKeyset, adLockOptimistic
            Rst.MoveLast
            LastRow = Rst.RecordCount + 1 'DERNIERE LIGNE +1 PUISQUE EN-TÊTE dans la feuille Excel
        End With
     
        '~~> Déclaration de l'instance Outlook
        Set oOlAp = GetObject(, "Outlook.application")
        Set oOlns = oOlAp.GetNamespace("MAPI")
        Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
     
        '~~> Chargement des informations de l'email dans les variables
        For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")
            eSender = oOlItm.SenderEmailAddress
            dtRecvd = "#" & Format(oOlItm.ReceivedTime, "yyyy/MM/dd") & "#"
            dtSent = Format(oOlItm.CreationTime, "yyyy/MM/dd hh:mm")
            NewFolder = Replace(dtSent, "/", " ")       '/ INTERDIT SOUS PEINE D'ERREUR
            NewFolder = Replace(NewFolder, ":", "-")    ': INTERDIT SOUS PEINE D'ERREUR
            sSubj = Replace(oOlItm.Subject, "'", " ")   '" INTERDIT SOUS PEINE D'ERREUR
            sMsg = oOlItm.Body
            eSenderName = oOlItm.SenderName
            EntryID = oOlItm.EntryID
     
        '~~> Vérification de la présence de pièce(s) jointe(s) dans l'email
            PJ = ""
            If oOlItm.Attachments.Count <> 0 Then PJ = "X"
            If Dir(AttachmentPath & NewFolder, vbDirectory) <> "" Then GoTo NextIteration 'Le dossier existe => Mail suivant
     
        '~~> Transfert des données Outlook vers Excel
            'Création de la requête
            Set ADOCommand = New ADODB.Command
     
            SQLStr = "INSERT INTO [" & FeuilleExcel & "$] " _
                & "VALUES (" & dtRecvd & ", " & _
                "'" & eSenderName & "', " & _
                "'" & eSender & "', " & _
                "#" & dtSent & "#, " & _
                "'" & sSubj & "', " & _
                "'" & PJ & "', " & _
                "'" & "=LIEN_HYPERTEXTE(" & Chr(34) & AttachmentPath & NewFolder & Chr(34) & ")" & "'" & ")"
     
    '------------------------------------------------------------
    '    Set Cn = New ADODB.Connection
    '    Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
            "Data Source=" & Fichier & ";" & _
            "Extended Properties=""Excel 8.0;HDR=No;"";"
     
    '    Set Cd = New ADODB.Command
    '    Cd.ActiveConnection = Cn
    '    Cd.CommandText = "SELECT * FROM [Feuil1$G30:G30]"
     
    '    Set Rst = New ADODB.Recordset
    '    Rst.Open Cd, , adOpenKeyset, adLockOptimistic
    '    Rst(0).Value = "Donnée test"
    '    Rst.Update
    '------------------------------------------------------------
     
            'Exécution de la requête
            Source.Execute SQLStr
     
        'Transfert du contenu de l'email dans le dossier nommé avec NewFolder
            MkDir (AttachmentPath & NewFolder)  'Création du dossier NewFolder
     
        '~~> Extraction des pièces jointes du mail
            '~~> Existe-t'il des pièces jointes dans l'email
            If oOlItm.Attachments.Count <> 0 Then
                For Each oOlAtch In oOlItm.Attachments
                    '~~> On les télécharge dans le dossier
                    oOlAtch.SaveAsFile AttachmentPath & NewFolder & "\" & oOlAtch.FileName
                Next
            End If
     
        '~~> Sauvegarde de l'email au format .msg (pratique pour le réouvrir dans son format d'origine dans Outlook)
            sEmail = AttachmentPath & NewFolder & "\" & "Email.msg"
            oOlItm.SaveAs sEmail, 3
     
        '~~> Sauvegarde du contenu de l'email dans un fichier .txt
            Mail = "Expéditeur : " & eSender & vbCrLf & vbCrLf
            Mail = Mail & "Date de réception : " & dtRecvd & vbCrLf
            Mail = Mail & "Date d'envoi : " & dtSent & vbCrLf & vbCrLf
            Mail = Mail & "Objet : " & sSubj & vbCrLf & vbCrLf
            Mail = Mail & "Message : " & sMsg & vbCrLf
     
            jour = Year(Now) & "-" & Month(Now) & "-" & Day(Now) & " - " & Hour(Now) & "-" & Minute(Now)
            NewFileName = " Email.txt"
            Open AttachmentPath & NewFolder & "\" & jour & NewFileName For Output As #1
            Print #1, Mail
            Close
            'Syntaxe pour ouvrir le fichier .txt (Pense-bête pour plus tard)
            'Shell "C:\WINDOWS\notepad.exe " & AttachmentPath & jour & NewFileName
     
        '~~> Marquer le mail en court de traitement (NON-LU) en LU
            'Dans ce cas, il faudra valider les trois lignes ci-dessous.
            'REMARQUE : Fonction peu pratique si on veut conserver l'état des emails lus et/ou non-lus
     
            'oOlItm.UnRead = False
            'DoEvents
            'oOlItm.Save
     
    NextIteration:
        Next
     
    Exit_Erreur:
        Rst.Close
        Source.Close
        Set Source = Nothing
        Set Rst = Nothing
        Set ADOCommand = Nothing
        Exit Sub
     
    Erreur:
        MsgBox "Erreur n°" & Err.Number & " - " & Err.Description, vbCritical, "Erreur de procédure !"
        Resume Exit_Erreur
     
    End Sub
    Pensez à mettre votre classeur Excel (nommé "Outlook.xlsm" dans un dossier de destination (il est en pièce jointe)
    J'ai pris :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    "R:\Downloads\Outlook\"
    En prime, le dossier se retrouve en lien hypertexte dans Excel, ce qui permet d'avoir un sommaire des mails reçus, le lien pour y accéder et le traitement d'Excel (filtre, tri, etc) pour s'y retrouver.
    A bientôt.
    PS: au premier pouce en l'air - ça fait plaisir
    Fichiers attachés Fichiers attachés
    Pas de demande par MP, sinon j'correctionne plus, j'dynamite, j'disperse, j'ventile !!!
    ---------------------------------------------------------------------
    Vous avez un talent insoupçonné... Faites-en profitez les autres. Un p'tit CLIC pour une grande cause.
    Et si vous faisiez un bon geste en 2021 ? Soyez utile, ça vous changera ! Moi, ça m’a changé !

  2. #2
    Membre du Club
    Inscrit en
    septembre 2007
    Messages
    127
    Détails du profil
    Informations forums :
    Inscription : septembre 2007
    Messages : 127
    Points : 69
    Points
    69
    Par défaut Outlook
    Bonjour, et félicitations pour votre contribution
    Juste une question quant au code à intégrer sous Outlook, pouvez-vous préciser dans quel module il doit être inséré ?
    Merci de votre retour
    Eric

  3. #3
    Membre chevronné Avatar de curt
    Homme Profil pro
    Ingénieur Etudes
    Inscrit en
    mars 2006
    Messages
    1 469
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations professionnelles :
    Activité : Ingénieur Etudes
    Secteur : Bâtiment Travaux Publics

    Informations forums :
    Inscription : mars 2006
    Messages : 1 469
    Points : 2 245
    Points
    2 245
    Par défaut
    Bonjour Eric,

    merci pour le message.
    Le code est à mettre dans l'éditeur VBA (Alt F11) dans le module "ThisOutlookSession"

    N'hésite pas à revenir si y a un problème.

    Curt
    Pas de demande par MP, sinon j'correctionne plus, j'dynamite, j'disperse, j'ventile !!!
    ---------------------------------------------------------------------
    Vous avez un talent insoupçonné... Faites-en profitez les autres. Un p'tit CLIC pour une grande cause.
    Et si vous faisiez un bon geste en 2021 ? Soyez utile, ça vous changera ! Moi, ça m’a changé !

Discussions similaires

  1. [WD17] Automatiser l'envoi d'un mail
    Par hicham-dj dans le forum WinDev
    Réponses: 2
    Dernier message: 27/08/2013, 11h28
  2. Automatisation de réception de la pièce jointe d'un mail POP3
    Par RvSpeed dans le forum Windows Forms
    Réponses: 0
    Dernier message: 28/05/2009, 10h24
  3. [OL-2003] Automatiser l'envoi de mail avec outlook
    Par jfox dans le forum Outlook
    Réponses: 1
    Dernier message: 20/03/2009, 22h47
  4. Réponses: 1
    Dernier message: 25/09/2007, 17h36
  5. [VB6] Executable automatisation macro excel + envoi mail
    Par jyrki69 dans le forum VB 6 et antérieur
    Réponses: 1
    Dernier message: 04/05/2006, 18h13

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo