VBA - Enregistrement piece jointe - objet

**sloang** · 15/06/2020, 20h20

Bonjour à tous,

J'ai besoin de votre aide !!

J'ai trouvé un code pour pouvoir enregistrer une pièce jointe directement dans un fichier sur l'ordinateur dès que le mail est reçu.
Donc script + règles

Je suis bloqué sur 2 points, je ne trouve pas de code pour :

1- Le fichier PDF est sauvegarder dans un dossier en prenant en compte les 7 premiers caractères de l'objet du mail
2- Enregistrement dans un dossier différent en fonction de la date présente dans l'objet du mail :
Voici un exemple d'objet : 00304-01 Hebdomadaire - Tous les salariés. 15/06/2020 - 21/06/2020

Je voudrais que quand il y a 15/06/2020 dans l'objet, ça enregistre dans le fichier 15/06/2020. Le reste de l'objet peut changer.

Ci dessous le code utilisé :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Sub SaveFS(Item As Outlook.MailItem)
 
        Set attachs = Item.Attachments
        For Each attach In attachs
            file = Mail.Sender.Name
            attach.SaveAsFile "C:\Users\sloang\Plannings 22.06.20\" & file
 
        Next
 
End Sub

Merci beaucoup pour votre aide !

Sloan

**Oliv-** · 16/06/2020, 10h19

Bonjour,
c'est pas très clair, entre dossier et fichier de destination

et 15/06/2020 c'est fixe où il faut trouver la première date dans le sujet ?

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
Sub SaveFS(Item As Outlook.MailItem)
 
        Set attachs = Item.Attachments
        For Each attach In attachs
 
 
Dim Fso, F, sExt
            Set Fso = CreateObject("Scripting.FileSystemObject")
 
'pour obtenir le nom du fichier sans l'extension
            F = Fso.GetBaseName(attach.FileName)
'pour obtenir l'extension
            sExt = Fso.GetExtensionName(attach.FileName)
 
'pour les 7 premiers caractères du sujet et on ajoute l'extension du fichier
            file = left(item.subject,7) & "." & sExt
 
if instr(item.subject , "15/06/2020", vbTextCompare)>0 then 
 
'avec le remplacement des \ par des .
' tu peux aussi utiliser format exemple :Msgbox  Format("15/06/2020", "dd.mm.yyyy")
            attach.SaveAsFile "C:\Users\sloang\Plannings " & replace("15/06/2020","/",".") & "\" & file
else
'sinon je fais rien
 
end if
 
        Next
 
End Sub

**sloang** · 16/06/2020, 11h04

Bonjour Oliv,

Merci pour ton retour.

L'objectif est que en fonction de la première date contenu dans l'objet :
- 15/06/2020 par exemple, ça m'enregistre la pièce jointe dans le dossier "Plannings 15.06.20",
- 22/06/2020, ça m'enregistre la pièce jointe dans le dossier "Plannings 22.06.20",

Donc, aujourd'hui j'ai une règle qui range directement le mail dans un dossier et qui exécute le script pour ranger la pièce jointe au nom de l'objet.
Au lieu de prendre les 7 premiers caractères, tu penses qu'il peut prendre la totalité de l'objet ?

Merci beaucoup pour ton aide Oliv

**Oliv-** · 16/06/2020, 11h32

alors pour trouver la date c'est un peu plus complexe mais on peut faire comme cela

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
Sub SaveFS(Item As Outlook.MailItem)
    Set attachs = Item.Attachments
    For Each attach In attachs
 
 
        Dim fso, F, sExt
        Set fso = CreateObject("Scripting.FileSystemObject")
 
        'pour obtenir le nom du fichier sans l'extension
        F = fso.GetBaseName(attach.Filename)
        'pour obtenir l'extension
        sExt = fso.GetExtensionName(attach.Filename)
 
        'on nomme avec le SUJET et on ajoute l'extension du fichier
        file = Left(Item.Subject, 7) & "." & sExt
 
 
        'on vérifie que le dossier existe et sinon on le créé
        Dim sdossier
        sdossier = "C:\Users\sloang\Plannings " & Format(RegExDate(Item.Subject), "dd.mm.yyyy")
 
        Call waaps_creedir(sdossier)
 
        attach.SaveAsFile sdossier & "\" & file
 
    Next
 
End Sub
 
 
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 Function RegExDate(s As String) As String
    Dim re, match
    Set re = CreateObject("vbscript.regexp")
    re.Pattern = "(0[1-9]|[12][0-9]|3[01])[- /.](0[1-9]|1[012])[- /.](19|20)[0-9]{2}"
    re.Global = True
 
    For Each match In re.Execute(s)
        'MsgBox match.Value
        RegExDate = match.Value
        Exit For
    Next
    Set re = Nothing
End Function

**sloang** · 16/06/2020, 11h47

Oliv,

Lors de la réception, ça me met un beug sur cette ligne la

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 Call waaps_creedir(sdossier)

Est ce que l'on peut faire plus simple dans ce cas ?

C'est à dire :

1- Réception du mail
2- Lancement de la règle avec le script
3- Enregistrement de la pièce jointe au nom de l'objet du mail dans un dossier unique ?

La pièce jointe sera uniquement des .PDF

C'est une urgence pour demain et j'en reçois beaucoup en ce moment

Merci pour ton aide

**Oliv-** · 16/06/2020, 12h43

Quelle erreur ?

**sloang** · 16/06/2020, 12h56

ça me met :

Erreur de compilation
Type d'argument ByRef incompatible

**Oliv-** · 16/06/2020, 12h56

Remplace la ligne par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 Call waaps_creedir(CStr(dossier))

**sloang** · 16/06/2020, 13h09

Le problème semble être résolu par cette ligne.

Maintenant, j'ai une nouvelle erreur :

Erreur d'exécution
Impossible d'enregistrer la pièce jointe. Ce chemin d'accès n'existe pas. Assurez-vous qu'il est correct.

Et voici la ligne de code qui bloque

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 attach.SaveAsFile sdossier & "\" & file

**Oliv-** · 16/06/2020, 13h27

si tu mets avant cette ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
msgbox sdossier & "\" & file

ça te donne quoi ?

**sloang** · 16/06/2020, 13h33

Alors maintenant,

Il n'y a plus de BUG sur le code mais :

- Ca m'ouvre une box à chaque réception de mail donc toutes les 10 secondes avec le lien de destination.
- Ca n'enregistre pas le fichier

**Oliv-** · 16/06/2020, 13h41

en fait c'est parce qu'il y des caractères interdits dans ton sujet

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
Sub test_Item()
Dim Item As Outlook.MailItem
    Set Item = ActiveInspector.CurrentItem
 
    SaveFS Item
End Sub
 
 
Sub SaveFS(Item As Outlook.MailItem)
    Set attachs = Item.Attachments
    For Each attach In attachs
 
 
        Dim fso, F, sExt
        Set fso = CreateObject("Scripting.FileSystemObject")
 
        'pour obtenir le nom du fichier sans l'extension
        F = fso.GetBaseName(attach.FileName)
        'pour obtenir l'extension
        sExt = fso.GetExtensionName(attach.FileName)
 
        'on nomme avec le SUJET et on ajoute l'extension du fichier
        FILE = remplaceCaracteresInterdit(Item.Subject) & "." & sExt
 
 
        'on vérifie que le dossier existe et sinon on le créé
        Dim sdossier
        sdossier = "C:\Users\sloang\Plannings " & Format(RegExDate(Item.Subject), "dd.mm.yyyy")
        sdossier = "C:\TEMP\A ENVOYER\Plannings " & Format(RegExDate(Item.Subject), "dd.mm.yyyy")
        Call waaps_creedir(CStr(Dossier))
 
        attach.SaveAsFile sdossier & "\" & FILE
 
    Next
 
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 = CheminStr
    'MsgBox CheminStr
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 Function RegExDate(s As String) As String
    Dim re, match
    Set re = CreateObject("vbscript.regexp")
    re.Pattern = "(0[1-9]|[12][0-9]|3[01])[- /.](0[1-9]|1[012])[- /.](19|20)[0-9]{2}"
    re.Global = True
 
    For Each match In re.Execute(s)
        'MsgBox match.Value
        RegExDate = match.Value
        Exit For
    Next
    Set re = Nothing
End Function

**sloang** · 16/06/2020, 13h46

En reprenant ton code,

Ca me remet le message d'erreur comme quoi le chemin d'accès n'existe pas...

**Oliv-** · 16/06/2020, 13h47

il faut commenter la ligne 29 utiliséé pour tester

**sloang** · 16/06/2020, 13h50

Commenter ? C'est à dire ?

Désolé je suis une quille

**sloang** · 16/06/2020, 13h52

Ahhhh
C'est ajouter l'apostrophe au début et à la fin c'est ça ?

**sloang** · 16/06/2020, 13h54

Mais même en le faisaint, j'ai un beug sur cette ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

attach.SaveAsFile sdossier & "\" & FILE

**Oliv-** · 16/06/2020, 13h57

désolé je n'ai pas de boule de cristal, donc si tu n'expliques pas je peux pas comprendre quel bug ?

**sloang** · 16/06/2020, 14h00

Oliv !!!

Moi qui pensais

Le bug est le suivant : Impossible d'enregistrer la pièce jointe. Ce chemin d'accès n'existe pas. Assurez-vous qu'il est correct.

sur la ligne suivante :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

attach.SaveAsFile sdossier & "\" & FILE

**Oliv-** · 16/06/2020, 14h02

donc tu dois vérifier s'il est correct

soit avec une msgbox soit avec debug.print, soit un regardant la valeur des variables....

mais tu n'as visiblement aucune notions de VBA ?!

VBA - Enregistrement piece jointe - objet

VBA Outlook

Discussions similaires

Partager

Partager