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
    Nouveau Candidat au Club
    Enregistrement pièces jointes selon nom de la pièce dans un dossier du même nom
    Bonjour

    J'utilise Outlook 2010, je souhaite utilise un code VBA pour permettre l'enregistrement d'une pièce jointe réceptionnée par mail.
    En prenant en compte le 'nommé' de la pièce jointe (les 6 premiers caractères), pour l'enregistrer dans un dossier du même nom (les 6 premiers caractères) ou un dossier défini par avance.
    J'ai trouve un code qui permet l'enregistrement a partir d'une règle Outlook, cela fonctionne pour un dossier, mais je ne sais pas comment faire pour créer plusieurs script vba pour chaque dossier, si c'est possible je peux créer plusieurs règle, même si le travail est fastidieux et m'oblige a créer 600 règles, je ne sais si Outlook va le supporter.

    Donc si vous avez une solution pour me permettre l'automatisation de mes enregistrements de pièces jointes je suis plus que preneur, même prêt a subventionner.
    Sachant que je suis novice en la matière.

    Pour résumer mon souhait :
    Le reçois un mail, avec une pièce jointe que je souhaite enregistrer dans un dossier, puis un autres mail avec une autre pièce jointe que je souhaite enregistrer dans un autre dossier. Sachant que les 6 premiers caractère qui nomme la pièce jointes sont différents ou 6 premier caractères de l'objet du mail.
    Le jour suivant je reçois un autre mail, nommé à identiquement qui doit aller dans le même dossier que celui reçu le précédemment.

    Les fichiers sont de type PDF.

    Merci d'avance pour votre aide.

  2. #2

  3. #3
    Nouveau Candidat au Club
    création dossier automatique - classement automatique
    Code copier dans ThisOutlookSession = OK

    Mais je ne comprend pas le fichier s'enregistre dans quel dossier ? c:/nom du fichier/nom du fichier.pdf
    J'ai tester mais je n'ai pas trouver de dossier et fichier correspondant au nom de mon fichier réceptionné.
    Pour info J'ai plusieurs compte mail, et je souhaite cette fonction que sur un compte.

    Faut t'il modifier #XM dans le code ?

  4. #4
    Nouveau Candidat au Club
    erreur
    J'ai une erreur sur la ligne 440

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    Item.Move objFolderDestination

  5. ###raw>post.musername###
    Expert éminent
    Bonjour,
    Quand tu parles de DOSSIER cela désigne des dossiers dans Outlook ou dans Windows ?

    Parce que la première macro concerne le classement interne à OUTLOOK, il faudrait donc adapter la seconde à ton besoin


    par exemple comme cela en partant du principe que les 6 premiers caractères du sujet représentent ton code

    à associer à une règle et l'action exécuter un script

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    Sub regle_exportPJ(Mail As Outlook.MailItem)
     
    Dim  Expediteur , WDestination
    Expediteur = Get_sender_SMTP(Mail)
    WDestination = "c:\temp\MesPJ\" & left(Mail.subject,6)
     
      Call ExportSuppression_PJ_v3(MyMail:=Mail, Export:=True, Supp:=False, SuppEmbedded:=False, DirExport:=WDestination , Deplace:=Falce, _
            DossierMove:="\\maboite\Traitements\EXPORT", BodyWrite:=True, PrefixePj:=Expediteur)
     
    End Sub
      0  0

  6. #6
    Nouveau Candidat au Club
    création dossier automatique - classement automatique
    Bonjour,

    IL sagit bien du dossier Windows

    J'ai ajouter ce code dans un module, j'ai supprimer l'ancien code dans thisoutlooksession.

    Jai cerer une regle avec script.

    J'ai fait un test

    Ci joint le message d'erreur

  7. #7

  8. #8
    Nouveau Candidat au Club
    Je dois copier le code principale ET le coller dans le module ?
    Au desus du script existant ?

  9. #9

  10. #10
    Nouveau Candidat au Club
    Bonjour

    Je crois que je tourne en rond et fait certainement n'importe quoi.
    J'ai coller les scripts demander et toutes les fonctions, tous ca dans module
    Cela me semble pas être la bonne méthode, pouvons nous résumer exactement ce que je dois entreprendre.


    JE PEUx VOUS DONNER ACCES AVEC TEAMVIEWER POUR FAIRE LE NECESSAIRE.
    ET vous payer cette prestation

  11. #11
    Nouveau Candidat au Club
    Un module vba par Regle outlook
    Bonjour

    Je suis revenu sur la base de créer un module VBA par règle Outlook
    Cela fait beaucoup de règles a créer mais cela fonction avec le code suivant

    Un Module par règle et je change que le SaveAttachementCO105
    Bien sur j'ai créer au préalable le dossier Windows qui correspond au classement que je souhaite, ici D:\CO105\

    Beaucoup de module VBA et de règles puisque j'ai environ 400 dossiers, mais cela fonctionne à défaut de mieux
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    Sub SaveAttachementCO105(Item As Outlook.MailItem)
            Set attachs = Item.Attachments
     
            For Each attach In attachs
                file = attach.FileName
                attach.SaveAsFile "D:\CO105\" & file
            Next
    End Sub


    Merci pour votre aide, si vous avez mieux je suis toujours preneur de toutes suggestions.
    En remerciant particulièrement Oliv- pour son aide.

  12. ###raw>post.musername###
    Expert éminent
    Bonjour,
    N'avais tu pas dit que le Dossier correspond aux 6 premiers caractères du SUjet du Mail ?
    Parce que dans ton exemple il n'y en a que 5

    Je te montre 2 façons :

    La tienne légèrement optimisée (une seule règle et seulement ce script):

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    Sub SaveAttachement_6(Item As Outlook.MailItem)
            Set attachs = Item.Attachments
            WDestination = left(item.subject,6)
            For Each attach In attachs
                file = attach.FileName
                attach.SaveAsFile "D:\" & WDestination & \" & file
            Next
    End Sub


    La Mienne:

    tu mets tout dans un module
    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
    246
    247
    248
    249
    250
    251
    252
    253
    254
    255
    256
    257
    258
    259
    260
    261
    262
    263
    264
    265
    266
    267
    268
    269
    270
    271
    272
    273
    274
    275
    276
    277
    278
    279
    280
    281
    282
    283
    284
    285
    286
    287
    288
    289
    290
    291
    292
    293
    294
    295
    296
    297
    298
    299
    300
    301
    302
    303
    304
    305
    306
    307
    308
    309
    310
    311
    312
    313
    314
    315
    316
    317
    318
    319
    320
    321
    322
    323
    324
    325
    326
    327
    328
    329
    330
    331
    332
    333
    334
    335
    336
    337
    338
    339
    340
    341
    342
    343
    344
    345
    346
    347
    348
    349
    350
    351
    352
    353
    354
    355
    356
    357
    358
    359
    360
    361
    362
    363
    364
    365
    366
    367
    368
    369
    370
    371
    372
    373
    374
    375
    376
    377
    378
    379
    380
    381
    382
    383
    384
    385
    386
    387
    388
    389
    390
    391
    392
    393
    394
    395
    396
    397
    398
    399
    400
    401
    402
    403
    404
    405
    406
    407
    408
    409
    410
    411
    412
    413
    414
    415
    416
    417
    418
    419
    420
    421
    422
    423
    424
    425
    426
    427
    428
    429
    430
    431
    432
    433
    434
    Sub regle_exportPJ(Mail As Outlook.MailItem)
     
    Dim  Expediteur , WDestination
    Expediteur = Get_sender_SMTP(Mail)
    WDestination = "c:\temp\MesPJ\" & left(Mail.subject,6)
     
      Call ExportSuppression_PJ_v3(MyMail:=Mail, Export:=True, Supp:=False, SuppEmbedded:=False, DirExport:=WDestination , Deplace:=Falce, _
            DossierMove:="\\maboite\Traitements\EXPORT", BodyWrite:=True, PrefixePj:=Expediteur)
     
    End Sub
     
     
     
    Sub ExportSuppression_PJ_v3(MyMail As Outlook.MailItem, Export As Boolean, Supp As Boolean, SuppEmbedded As Boolean, DirExport As String, _
    Deplace As Boolean, DossierMove As String, BodyWrite As Boolean, Optional PrefixePj As String = "")
    '---------------------------------------------------------------------------------------
    ' Procedure : ExportSuppression_PJ
    ' Author    : Oliv
    ' Date      : 21/12/2015
    ' Purpose   : Script pour archiver/supprimer les PJ , déplacer l'Email en ajoutant des liens hypertextes vers les fichiers archivés
    '---------------------------------------------------------------------------------------
        Dim NomsPJ As String
        Dim repertoire As String
        Dim Nbpj As Integer
        Dim i As Integer, n As Integer, MemPath, PathNomExport, OuCommenceAdresse, fin, BaliseBody
        Dim pj As Attachment
        Dim Separateur As Variant
        Dim NbTiret As Integer
        Dim Link
        Dim olNS As Outlook.NameSpace
        Dim Expediteur
        Dim Erreur
     
     
        Nbpj = MyMail.Attachments.Count
        If Nbpj > 0 Then
     
     
            'on identife le format du mail
            Select Case MyMail.BodyFormat
            Case olFormatHTML:
                Separateur = "<BR>"
                NbTiret = 45
            Case olFormatPlain:
                Separateur = Chr(10)
                NbTiret = 35
            Case Else
                Separateur = " - "
                NbTiret = 50
            End Select
     
            If Export Then
                'on crée le repertoire windows où mettre les fichiers joints ##########################################################
                If Right(DirExport, 1) <> "\" Then DirExport = DirExport & "\"
                repertoire = DirExport
                If waaps_creedir(repertoire) = False Then
                    Erreur = Erreur & vbCr & "repertoire : " & repertoire & " inaccessible"
                    GoTo fin
                End If
            End If
     
            'on prépare le message a ajouter un Coprs du Mail
            If Export And Supp Then
                NomsPJ = IIf(Nbpj = 1, "Pièce jointe exportée et supprimée", "Pièces jointes exportées et supprimées") & " du message initial : " & Separateur & String(NbTiret, "-")
            ElseIf Export Then
                NomsPJ = IIf(Nbpj = 1, "Pièce jointe exportée", "Pièces jointes exportées") & " du message initial : " & Separateur & String(NbTiret, "-")
            ElseIf Supp Then
                NomsPJ = IIf(Nbpj = 1, "Pièce jointe supprimée", "Pièces jointes supprimées") & " du message initial : " & Separateur & String(NbTiret, "-")
            Else
                GoTo deplacement
            End If
     
     
     
            Dim TypeAtt
            'on traite les pj
            For i = Nbpj To 1 Step -1
                Set pj = MyMail.Attachments(i)
                Link = ""
                'vérification si c'est une  PJ  Embedded
                TypeAtt = PJ_Isembedded(pj)
     
                If TypeAtt = False Or SuppEmbedded Then
                    n = 1
                    MemPath = remplaceCaracteresInterdit(PrefixePj & "¤" & pj.FileName)
                    PathNomExport = MemPath
                    If Export Then
                        While Dir(repertoire & PathNomExport) <> ""
                            'MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
                            PathNomExport = "(" & n & ")" & MemPath
                            n = n + 1
                        Wend
                        pj.SaveAsFile repertoire & PathNomExport
     
     
                        If MyMail.BodyFormat = olFormatHTML Then
                            Link = " <a href=""file:///" & GetUNC(repertoire & PathNomExport) & """>" & PathNomExport & "</a>"
                        Else
                            Link = "file:///" & GetUNC(repertoire & PathNomExport)
                        End If
     
                    End If
     
                    NomsPJ = NomsPJ & Separateur & " - " & pj.FileName & "| " & MEF_Octet_Short(pj.Size) & " -->" & Link
     
                    If Supp Then
                        pj.Delete
                    End If
                End If
            Next i
     
            If BodyWrite Then
                Select Case MyMail.BodyFormat
                Case olFormatHTML:
     
                    OuCommenceAdresse = InStr(1, MyMail.HTMLBody, "<BODY", vbTextCompare)
                    If OuCommenceAdresse > 0 Then
                        fin = InStr(OuCommenceAdresse + 5, MyMail.HTMLBody, ">") + 1
                        BaliseBody = Mid(MyMail.HTMLBody, OuCommenceAdresse, fin - OuCommenceAdresse)
     
                        MyMail.HTMLBody = Replace(MyMail.HTMLBody, BaliseBody, BaliseBody & "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & NomsPJ & "</font><BR>" _
                                                                             & "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>", 1, 1, vbTextCompare)
                    Else: MyMail.HTMLBody = "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & NomsPJ & _
                                            "</font><BR>" & "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>" & MyMail.HTMLBody
     
                    End If
                Case Else
                    MyMail.Body = NomsPJ & Chr(10) & String(NbTiret, "-") & Chr(10) & Chr(10) & MyMail.Body
     
                End Select
     
            End If
     
            'ICI on applique divers traitements sur le mail d'origine
            'drapeau vert
            MyMail.FlagIcon = olGreenFlagIcon
     
            'Marque lu
            MyMail.UnRead = False
     
            'Sauvegarde
            MyMail.Save
     
    deplacement:
            'on déplace le mail vers un dossier outlook
            If Deplace Then
                Dim myDestFolder As Outlook.MAPIFolder
    ' on cherche le dossier et on essaye  de le creér
     
               Set myDestFolder = GetFolderByPath(DossierMove, True)
                If Not myDestFolder Is Nothing Then
                    MyMail.Move myDestFolder
                Else
                    Erreur = Erreur & vbCr & "Email non déplacé :" & DossierMove & " Dossier non trouvé"
                End If
            End If
        End If
        Set MyMail = Nothing
        Set olNS = Nothing
    fin:
     
        If Erreur <> "" Then
            MsgBox Erreur, vbCritical, "Des erreurs se sont produites !"
        End If
    End Sub
     
     
     
    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
     
     
    Private Function PJ_Isembedded(ByVal pj As Attachment) As Boolean
    '---------------------------------------------------------------------------------------
    ' Procedure : PJ_Isembedded pour OL2010
    ' Author    : OLIV-
    ' Date      : 05/06/2015
    ' Version   : 2
    ' Purpose   : Indique si une PIECE JOINTE est INCORPOREE dans le Corps du Mail
    '---------------------------------------------------------------------------------------
    '
        Dim oPA As Outlook.PropertyAccessor
     
        Dim ATTACH_MIME_TAG
        Dim ATTACH_CONTENT_ID
        Dim ATTACHMENT_HIDDEN
        Dim ATTACH_FLAGS
        Dim ATTACH_CONTENT_LOCATION
        Dim ATTACH_METHOD
     
     
        Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
        Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
        Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
        Const PR_ATTACH_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x37140003"
        Const PR_ATTACH_CONTENT_LOCATION = "http://schemas.microsoft.com/mapi/proptag/0x3713001E"
        Const PR_ATTACH_METHOD = "http://schemas.microsoft.com/mapi/proptag/0x37050003"
     
        Set oPA = pj.PropertyAccessor
     
        On Error Resume Next
        ATTACH_MIME_TAG = oPA.GetProperty(PR_ATTACH_MIME_TAG)
        ATTACHMENT_HIDDEN = oPA.GetProperty(PR_ATTACHMENT_HIDDEN)
        ATTACH_CONTENT_ID = oPA.GetProperty(PR_ATTACH_CONTENT_ID)
        ATTACH_FLAGS = oPA.GetProperty(PR_ATTACH_FLAGS)
        ATTACH_CONTENT_LOCATION = oPA.GetProperty(PR_ATTACH_CONTENT_LOCATION)
        ATTACH_METHOD = oPA.GetProperty(PR_ATTACH_METHOD)
     
     
        If (ATTACH_CONTENT_ID <> "" And ATTACH_FLAGS = 4) Or ATTACH_METHOD = 6 Then
            PJ_Isembedded = True
        Else
            PJ_Isembedded = False
        End If
     
    End Function
     
     
    Private 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é
    '----------------------------------------------------------------------
        On Error Resume Next
        Dim fso As Object, i As Integer, retour As Boolean
        Dim rp As String, r
        Dim rep, REP_TOP
     
        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 Sub testGetUNC()
        MsgBox GetUNC("C:\Users\OLIV\Desktop\IconesRappelSuite.jpg", False)
    End Sub
     
    Private Function GetUNC(strMappedDrive As String, Optional UNClocal As Boolean) As String
    '---------------------------------------------------------------------------------------
    ' Procedure : GetUNC
    ' Author    : http://pagecommunication.co.uk/2014/07/vba-to-convert-a-mapped-drive-letter-to-unc-path/
    ' Author    : modified by oliv-
    ' Date      : 20/04/2018
    ' Version   : 2
    '---------------------------------------------------------------------------------------
    '
        Dim objFso As Object
        Set objFso = CreateObject("Scripting.filesystemobject")
        Dim strDrive As String
        Dim strShare As String
        'Separated the mapped letter from
        'any following sub-folders
        Dim oDrive As Object
        strDrive = objFso.GetDriveName(strMappedDrive)
        Set oDrive = objFso.GetDrive(strDrive)
     
        'find the UNC share name from the mapped letter
        strShare = oDrive.ShareName
     
        If strShare = "" Then
            If UNClocal Then
                strShare = "\\" & Environ("computername") & "\" & Replace(strDrive, ":", "$")
            Else
                GetUNC = strMappedDrive
                Exit Function
            End If
        End If
        'The Replace function allows for sub-folders
        'of the mapped drive
        GetUNC = Replace(strMappedDrive, strDrive, strShare)
     
        Set objFso = Nothing    'Destroy the object
    End Function
     
     
    Private Function MEF_Octet_Short(lgValeur As Double) As String
    '---------------------------------------------------------------------------------------
    ' Procédure : MEF_Octet_Short
    ' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
    ' Date      : 25/04/2008
    ' Détail    : Fonction permettant un affichage en octet, kilo, mega ou giga selon valeur passée en paramètre
     
    ' Modif par : joe.levrai
    ' Date      : 25/04/2015
    ' Détail    : conversion des If imbriqués en une boucle While Wend avec utilisation d'un tableau d'unités
    '---------------------------------------------------------------------------------------
        Dim tableau, i
        tableau = Array("Oct", "Ko", "Mo", "Go")  ' stockage des unités
     
        While (lgValeur / 1024 > 1) And i < UBound(tableau)  ' itération des divisions par 1024
            i = i + 1  ' décalage de l'unité
            lgValeur = lgValeur / 1024
        Wend
     
        MEF_Octet_Short = CStr(Round(lgValeur, 2)) & " " & tableau(i)
     
    End Function
     
     
    Function GetFolderByPath(ByVal FolderPath As String, Optional CreateSubFolders As Boolean) As Outlook.Folder
    '---------------------------------------------------------------------------------------
    ' Procedure : GetFolderByPath
    ' Author    : Diane Poremsky
    ' Modified by : Oliv
    ' Date      : 20/10/2016
    ' Purpose   : Obtenir un dossier OL à partir de son chemin en créant au besoin les sous-dossiers
    '---------------------------------------------------------------------------------------
    '
        Dim oFolder As Outlook.Folder
        Dim FoldersArray As Variant
        Dim i As Integer
        Dim ParentFolder As Folder
     
        On Error GoTo GetFolderByPath_Error
        If Left(FolderPath, 2) = "\\" Then
            FolderPath = Right(FolderPath, Len(FolderPath) - 2)
        End If
        FoldersArray = Split(FolderPath, "\")
        Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
        If Not oFolder Is Nothing Then
            On Error Resume Next
            For i = 1 To UBound(FoldersArray, 1)
                Dim SubFolders As Outlook.Folders
                Set SubFolders = oFolder.Folders
                Set ParentFolder = SubFolders.Item(FoldersArray(i))
                If ParentFolder Is Nothing Then
                    If CreateSubFolders Then
                        Set ParentFolder = SubFolders.Add(FoldersArray(i))
                    Else
                        Set GetFolderByPath = Nothing
                        Exit Function
                    End If
                End If
                Set oFolder = SubFolders.Item(FoldersArray(i))
                If oFolder Is Nothing Then
                    Set GetFolderByPath = Nothing
                    Exit Function
                End If
                Set ParentFolder = Nothing
            Next
        End If
        Set GetFolderByPath = oFolder
        Exit Function
     
    GetFolderByPath_Error:
        Set GetFolderByPath = Nothing
        'Resume
        Exit Function
    End Function
     
    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


    dans les 2 cas tu dois avoir une règle avec l'action exécuter un script
      0  0

  13. #13
    Nouveau Candidat au Club
    Bonjour

    J'ai ajouter un module avec le premier code, mais cela ne fonctionne pas.
    J'ai créer le dossier au préalable sous D:\CO105

    Ce repertoire n'existe pas


  14. #14
    Nouveau Candidat au Club
    Bonjour

    A force de faire des test en modifiant legerment le script, j'ai trouver
    attach.SaveAsFile "D:\" & WDestination & "\" & file


    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    Sub SaveAttachement_5(Item As Outlook.MailItem)
            Set attachs = Item.Attachments
            WDestination = Left(Item.Subject, 5)
            For Each attach In attachs
                file = attach.FileName
                attach.SaveAsFile "D:\" & WDestination & "\" & file
            Next
    End Sub


    Ca fonctionne, GENIAL



    Merci Oliv- tu ai au top

    Je vais essayer l'autre version, quel sont les avantage de la deuxieme ?
    - Création du dossier automatique ? …..

  15. #15
    Expert éminent
    Salut,
    Oui désolé il y avait une erreur , il manquait effectivement une double quote.

    En fait ma version est une fonction avec des paramètres, il y a effectivement création du dossier, et incrémentation des noms de pièces jointes si un fichier de ce nom existe déjà.

    tu peux aussi exclure les pièces jointes qui sont dans le corps du Mail



    -Export des pièces jointes dans un répertoire (Windows) -->Export :=true avec renseignement du répertoire de destination DirExport ="c:\temp\
    -Suppression de Pièces jointes du Mail -->Supp:=true
    -Ignore les pièces jointes incorporées dans le corps du Mail. -->SuppEmbedded :=false
    -Ajout dans le corps du Mail, du nom des pièces jointes traitées, de leur taille et lien hypertext vers le fichier exporté. -->info :=True
    -Classement du mail dans un Dossier OUTLOOK différent -->Deplace:=true en renseignant le dossier DossierMove ="C:\temp\"
    -Préfixe devant le nom des picèces jointes : PrefixePj:="cequejeveux"
    -Ajouter l'information dans le mail d'origine

    -Flag du mail
    -Mail passé en lu.

  16. #16
    Nouveau Candidat au Club
    message erreur si dossier non present
    Bonjour

    Me revoila le script fonctionne bien, mai j'ai un petit problème, si le dossier n'existe pas, alors message d'erreur ci dessous.
    Je souhaite pas enregistrer la pièce jointe si l'objet ne contiens pas les 5 premiers caractère qui permettent le classement dans le dossier correspondant.
    Comment puis-je faire pour ne pas avoir cette erreur Outlook ?

    Merci d'avance



    Pour info j'utilise ce script :
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
     
    Sub SaveAttachement_5(Item As Outlook.MailItem)
            Set attachs = Item.Attachments
            WDestination = Left(Item.Subject, 5)
            For Each attach In attachs
                file = attach.FileName
                attach.SaveAsFile "D:\CONTRAT\" & WDestination & "\" & file
            Next
    End Sub

  17. #17
    Expert éminent
    Bonjour
    Avant la ligne 5 tu ajoutes
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    call waaps_creedir ("D:\CONTRAT\" & WDestination & "\")



    et dans un module (si la fonction n'existe pas déjà)

    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
    Private 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é
    '----------------------------------------------------------------------
        On Error Resume Next
        Dim fso As Object, i As Integer, retour As Boolean
        Dim rp As String, r
        Dim rep, REP_TOP
     
        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



    Je souhaite pas enregistrer la pièce jointe si l'objet ne contiens pas les 5 premiers caractère qui permettent le classement dans le dossier correspondant.
    Comment puis-je faire pour ne pas avoir cette erreur Outlook ?
    Comment sais tu que les 5 premiers caractères de l'objet sont ou pas un code ?

  18. #18
    Nouveau Candidat au Club
    Question : Je souhaite pas enregistrer la pièce jointe si l'objet ne contiens pas les 5 premiers caractère qui permettent le classement dans le dossier correspondant.
    Comment puis-je faire pour ne pas avoir cette erreur Outlook ?

    réponse :
    L'objet du message contiens les 5 premiers caractère de mon dossier
    - il s'agit d'un envoi depuis un logiciel PRAXEDO (gestion d'intervention), que j'ai paramètre pour qu'il m'envoi le mail avec le code correspondant au client.

  19. #19
    Nouveau Candidat au Club
    et dans un module (si la fonction n'existe pas déjà)

    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
    Private 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é
    '----------------------------------------------------------------------
        On Error Resume Next
        Dim fso As Object, i As Integer, retour As Boolean
        Dim rp As String, r
        Dim rep, REP_TOP
     
        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



    ce script servira a créer un répertoire si ABSENT ?
    Je n'en ai pas besoins.
    Si non :
    DANS QUEL MODULE ?
    il faut que je créer un nouveau module ?
    je le renome ?

  20. #20