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

  1. #1
    Membre régulier
    "Comment enregistrer mes messages sur disque dur" Y compris les sous-dossiers
    Bonjour à tous

    le programme "Comment enregistrer mes messages sur disque dur" sur la FAQ MS-Outlook fonctionne très bien,
    je voudrais si c'est possible y inclure les sous-dossiers, mais bien entendu, je ne sais pas comment faire, merci à tous pour votre aide.

  2. #2

  3. #3
    Membre régulier
    Bonjour Oliv_

    merci beaucoup,
    je tente à faire des tests et j'ai un message d'erreur,
    effectivement il ne trouve pas la procédure nommée ProcessThisItem
    je connais un peu VBA Excel, mais très peu VBA Outlook



  4. #4
    Expert éminent
    tu as oublié la seconde partie du code sur le premier lien

    c'est dans cette partie que tu dois mettre la fonction
    SavAs_mail_as_msg
    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
     
     
     
    Sub ProcessThisItem(objitem As Object)
    '---------------------------------------------------------------------------------------
    ' Procedure : ProcessThisItem
    ' Author    : Oliv
    ' Date      : 12/02/2016
    ' Purpose   :
    '---------------------------------------------------------------------------------------
    '
        If objitem.Class = olMail Then
            Dim MyMail As Outlook.MailItem
            Set MyMail = objitem
     
           'ici le code
           call SavAs_mail_as_msg (objitem, "c:\temp\")
        End If
     
     
    End Sub

  5. #5
    Membre régulier
    Bonjour à tous,
    Oliv-
    je pensais avoir tout copié,

    je viens de recopier la partie manquante, et lancé la macro,
    le programme me demande de déclarer certaines variables ce que j'ai fait,

    déjà sur la procédure Sub SavAs_mail_as_msg(MyMail As Outlook.MailItem, repertoire), j'ai créé
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
     Dim NomExport As String
     Dim PathNomExport As String
     Dim n As Integer
     Dim MemPath As String


    puis sur la procédure Function waaps_creedir(lerep As String) As Boolean, j'ai créé
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
        Dim rep As String
        Dim REP_TOP As String


    maintenant sur cette procédure il me demande un tableau car il bloque sur Ubound



    je ne sais pas si toutes les déclarations sont bonnes
    mais avec les tableaux je n'y connais rien

  6. #6
    Membre régulier
    Bonjour Olivier,
    je me suis aperçu qu'il y avait des procédures en doublons d'où les erreurs,
    j'ai effacé toutes les anciennes procédures et je n'ai copié que celles indiquées dans tes liens (liste image ci-dessous)

    il n'y a plus de message d'erreur,
    une fenêtre me demande quel répertoire sélectionner,
    aussitôt, un message m'indique "traitement terminé"
    et il n'y a rien dans mon répertoire C:\mail (le répertoire existe bien)
    je dois peut-être indiquer l'appel d'une procédure quelque part ?
    merci beaucoup pour ton aide



  7. #7
    Expert éminent
    Bonjour
    y a t'il bien le \ à la fin du chemin ?

    sinon regarde à la racine si tu as des fichiers mailquelquechose.msg

  8. #8
    Membre régulier
    Bonjour Olivier,
    oui il y a bien le \ à la fin du chemin
    par contre j'ai fait une recherche et il n'y a pas d'appel à la procédure SavAs_mail_as_msg (call SavAs_mail_as_msg)

  9. #9
    Expert éminent
    Salut,
    Y a effectivement des trucs bizarres dans mon code , j'ai corrigé

    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
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    207
    208
    209
    210
    211
    212
    213
    214
    215
    216
    217
    218
    219
    220
    221
    222
    223
    224
    225
    226
    227
    228
    229
    230
    231
    232
    233
    234
    235
    236
    237
    238
    239
    240
    241
    242
    243
    244
    245
    Option Explicit
     
     
    Sub Lance_Traitement()
    '---------------------------------------------------------------------------------------
    ' Procedure : Lance_Traitement
    ' Author    : Oliv
    ' Date      : 12/02/2016
    ' Purpose   :
    '---------------------------------------------------------------------------------------
    '
        Dim OL As Outlook.Application
        Dim olNS As Outlook.NameSpace
        Dim olFolder As Outlook.Folder
     
        Set OL = Outlook.Application
        Set olNS = OL.GetNamespace("MAPI")
     
        'soit on connait le dossier
        'Set olFolder = olNS.GetDefaultFolder(olFolderInbox).folders
     
        'soit on le choisi
        Set olFolder = olNS.PickFolder
     
        Call ProcessFolders(olFolder, True)
        MsgBox "Traitement terminé"
    End Sub
     
    Sub ProcessFolders(StartFolder As Outlook.MAPIFolder, SubFolder As Boolean)
    '---------------------------------------------------------------------------------------
    ' Procedure : ProcessFolder
    ' Author    : Oliv'
    ' Date      : 12/02/2016
    ' Purpose   : Traitement récursif sur les dossiers OUTLOOK
    '---------------------------------------------------------------------------------------
    '
        Dim objFolder As Outlook.MAPIFolder
        Dim objitem As Object
     
        'Dim objItem As Object
        On Error Resume Next
     
        ' do something specific with this folder
        Debug.Print StartFolder.FolderPath, StartFolder.Items.Count
        Debug.Print
        If StartFolder.DefaultItemType = olMailItem Then
            '  ICI LE TRAITEMENT POUR CHAQUE DOSSIER
            ' Call ProcessThisFolder(StartFolder)
        End If
     
        ' process all the items in this folder
        'ICI LE TRAITEMENT POUR TOUS LES ELEMENTS DU DOSSIER
     
        Dim i
        For i = StartFolder.Items.Count To 1 Step -1
            Set objitem = StartFolder.Items(i)
            Call ProcessThisItem(objitem)
        Next i
     
        ' process all the subfolders of this folder
        'on traite tous les sous dossiers
        If SubFolder Then
            For Each objFolder In StartFolder.Folders
                Call ProcessFolders(objFolder, SubFolder)
            Next
        End If
     
        Set objFolder = Nothing
    End Sub
     
     
     
     
    Sub ProcessThisItem(objitem As Object)
    '---------------------------------------------------------------------------------------
    ' Procedure : ProcessThisItem
    ' Author    : Oliv
    ' Date      : 12/02/2016
    ' Purpose   :
    '---------------------------------------------------------------------------------------
    '
        If objitem.Class = olMail Then
            Dim MyMail As Outlook.MailItem
            Set MyMail = objitem
     
            'ici le code
            Call SavAs_mail_as_msg(objitem, "c:\temp\")
        End If
     
     
    End Sub
     
     
    Sub SavAs_mail_as_msg(MyMail As Outlook.MailItem, repertoire)
    '---------------------------------------------------------------------------------------
    ' Procedure : SavAs_mail_as_msg
    ' Author    : Oliv
    ' Date      : 12/02/2016 modifié 01/07/2020
    ' Purpose   :
    '---------------------------------------------------------------------------------------
    '
    ' exemple repertoire = "c:\mail\"
        Dim NomExport As String
        Dim PathNomExport As String
        Dim n As Integer
        Dim MemPath As String
     
        'Ici on construit le nom du fichier qui sera créé
        'par exemple : DATE CREATION + EXPEDITEUR + SUJET
        Dim Expediteur
        Expediteur = Get_sender_SMTP(MyMail)
        NomExport = Format(MyMail.CreationTime, "yyyymmdd hh:nn") & "-" & Expediteur & "-" & MyMail.Subject
        NomExport = remplaceCaracteresInterdit(NomExport)
     
        'Ici on vérifie le répertoire où l'enregistrer
        If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\"
        Call waaps_creedir(CStr(repertoire))
     
     
        'On construit le chemin et le nom du fichier pour l'export
        PathNomExport = repertoire & Left(NomExport, 160) & ".msg"
     
        'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
        n = 1
        MemPath = PathNomExport
        While Dir(PathNomExport) <> ""
            'MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
            PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
            n = n + 1
     
        Wend
        MyMail.SaveAs PathNomExport, OlSaveAsType.olMSG
     
        ' pour changer la date du fichier (voir en bas)
        '    Call ModifDate(CStr(PathNomExport), MyMail.CreationTime, 4)
     
        'on peut aussi l'enregistrer dans d'autres formats
        'Type de fichier à enregistrer. Il peut s'agir d'une des constantes OlSaveAsType suivantes : olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal ou olMSGUnicode.
     
    End Sub
     
     
    Function remplaceCaracteresInterdit(ByVal CheminStr As String)
        Dim objCurrentMessage As Outlook.MailItem
     
        Dim liste As Variant
        Dim L
        liste = Array("\", "/", ":", "*", "?", "<", ">", "|", """", vbTab, Chr(7))
        For L = 0 To UBound(liste)
            CheminStr = Replace(CheminStr, liste(L), "")
        Next L
        remplaceCaracteresInterdit = Trim(CheminStr)
        'MsgBox CheminStr
    End Function
     
     
    Function waaps_creedir(lerep As String) As Boolean
    '----------------------------------------------------------------------
    ' FUNCTION :    waaps_creedir
    '               Création d'un répertoire (récursif)
    '----------------------------------------------------------------------
    ' Paramètres :
    '   rep :       répertoire à créer par son chemin relatif % au root
    '----------------------------------------------------------------------
    '   retour :    True si le répertoire est créé
    '----------------------------------------------------------------------
    ' Global utilisé : REP_TOP
    '----------------------------------------------------------------------
    ' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA
    '   Utilisation commerciale interdite
    '   Utilisation personnelle / professionnelle autorisée
    '   Le message courant doit être préservé
    '----------------------------------------------------------------------
        Dim FSO As Object, i As Integer, retour As Boolean
        Dim rp As String, r
        Dim rep As Variant
        Dim REP_TOP As String
     
     
        Set FSO = CreateObject("Scripting.filesystemobject")
     
        rp = Replace(lerep, "\", "/")
        rp = Replace(rp, "//", "/")
        rep = Split(rp, "/")
        r = REP_TOP
        retour = True
        For i = 0 To UBound(rep)
            If (rep(i) <> "") Then
                r = r & rep(i) & "\"
                If (Not FSO.FolderExists(r)) Then
                    FSO.CreateFolder (CStr(r))
                    If (Not FSO.FolderExists(r)) Then retour = False
                End If
            End If
        Next
        Set FSO = Nothing
        waaps_creedir = retour
    End Function
     
    Private Function Get_sender_SMTP(Oitem As Outlook.MailItem) As String
        Dim oEU As Outlook.ExchangeUser
        On Error Resume Next
        Set oEU = Oitem.Sender.GetExchangeUser
     
        Get_sender_SMTP = oEU.PrimarySmtpAddress
     
        If Get_sender_SMTP = "" Then Get_sender_SMTP = GetFromFromHeader(Oitem)
     
     
        If Get_sender_SMTP = "" Then Get_sender_SMTP = Oitem.SenderEmailAddress
    End Function
     
    Function GetFromFromHeader(objMail As Outlook.MailItem) As String
    '---------------------------------------------------------------------------------------
    ' Procedure : GetToFromHeader
    ' Author    : OLIV- from original code brettdj
    ' Date      : 04/06/2015
    ' Purpose   :
    '---------------------------------------------------------------------------------------
    '
        Dim objRegex As Object
        Dim objRegM As Object
        Dim MailHeader As String
        Dim ExtractText As String
        Dim i
        Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001F"
        MailHeader = objMail.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
     
        Set objRegex = CreateObject("vbscript.regexp")
        With objRegex
            .ignorecase = True
            .Pattern = "(\n)From:.*<(.+)>"
            If .test(MailHeader) Then
                Set objRegM = .Execute(MailHeader)
                For i = 0 To objRegM(0).submatches.Count - 1
                    If InStr(1, objRegM(0).submatches(i), "@", vbTextCompare) Then
                        GetFromFromHeader = objRegM(0).submatches(i)
                        Exit For
                    End If
                Next i
            Else
                GetFromFromHeader = ""
            End If
        End With
    End Function

  10. #10
    Membre régulier
    Bonjour Olivier,
    Cela fonctionne très bien,
    je n'ai plus besoin de sélectionner tous les mails, sous-dossiers par sous-dossiers
    le gain de temps est impressionnant,
    de plus, je ne risque pas de passer à coté d'un sous-dossier, ni de manquer un mail lors de la selection
    merci beaucoup





    je voulais savoir encore une chose,
    serait-il possible de créer aussi les sous-dossier ?

  11. ###raw>post.musername###
    Expert éminent
    Salut

    effectivement on peut reproduire l'arborescence.

    Dans le code déclencheur

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    Call SavAs_mail_as_msg(objitem, "c:\temp\",true)



    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
    Sub SavAs_mail_as_msg(mymail As Outlook.MailItem, repertoire, Optional withArbo As Boolean)
    '---------------------------------------------------------------------------------------
    ' Procedure : SavAs_mail_as_msg
    ' Author    : Oliv
    ' Date      : 12/02/2016 modifié 03/07/2020
    ' Purpose   :
    '---------------------------------------------------------------------------------------
    '
    ' exemple repertoire = "c:\mail\"
        Dim NomExport As String
        Dim PathNomExport As String
        Dim n As Integer
        Dim MemPath As String
     
        'Ici on construit le nom du fichier qui sera créé
        'par exemple : DATE CREATION + EXPEDITEUR + SUJET
        Dim Expediteur
        Expediteur = Get_sender_SMTP(mymail)
        NomExport = Format(mymail.CreationTime, "yyyymmdd hh:nn") & "-" & Expediteur & "-" & mymail.Subject
        NomExport = remplaceCaracteresInterdit(NomExport)
     
        'Ici on vérifie le répertoire où l'enregistrer
        If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\"
     
        If withArbo Then
            Dim arbo As String
            Dim ofolder As Outlook.Folder
     
            Set ofolder = mymail.Parent
            arbo = ofolder.FolderPath
            'soit on supprime le nom de la boite
            repertoire = repertoire & Replace(arbo, "\\" & ofolder.Store.displayName & "\", "", , , vbTextCompare) & "\"
            'soit on le laisse
            'repertoire = repertoire & Replace(arbo, "\\", "") & "\"
     
        End If
     
        Call waaps_creedir(CStr(repertoire))
     
     
        'On construit le chemin et le nom du fichier pour l'export
        PathNomExport = repertoire & Left(NomExport, 160) & ".msg"
     
        'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
        n = 1
        MemPath = PathNomExport
        While DIR(PathNomExport) <> ""
            'MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
            PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
            n = n + 1
     
        Wend
        mymail.SaveAs PathNomExport, OlSaveAsType.olMSG
     
        ' pour changer la date du fichier (voir en bas)
        '    Call ModifDate(CStr(PathNomExport), MyMail.CreationTime, 4)
     
        'on peut aussi l'enregistrer dans d'autres formats
        'Type de fichier à enregistrer. Il peut s'agir d'une des constantes OlSaveAsType suivantes : olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal ou olMSGUnicode.
     
    End Sub
      1  0

  12. #12
    Membre régulier
    Bonjour Olivier,
    Super,
    j'avais un projet contenant 38 répertoires dont quelques-uns en avaient aussi avec un total de 380 mails
    j'ai réussi à créer un historique d'un projet très rapidement, tout en respectant ma structure
    je pourrai aussi créer un historique à chaque fin de projet, il suffira que je monte bien ma structure pour l'arborescence
    chose que je ferai au fur et à mesure de chaque projet

    tu fait partie des élites
    un très grand merci