Enregistrement dans des dossiers spécifiques

**theolerouleau** · 22/12/2016, 10h57

Bonjour à tous,

Actuellement en stage dans une entreprise, j'ai pour mission d'automatiser une boite mail partagée. Ce qui me pose beaucoup de problèmes étant donné que mes connaissances en VBA sont très limité de par ma formation (ingénieur en génie industriel)

Voici mon problème: Des fournisseurs envoient de la documentation par mail en utilisant la syntaxe suivante dans l'objet du mail :
"CONTRAT\FOURNISSEURS\NUMÉRO D'ARTICLE \ANNÉE\BLXXXX"

Mon programme doit enregistrer les pièces jointes suivant la syntaxe donnée ci-dessus dans le dossier :
"C:\Documents\CONTRAT\FOURNISSEURS\NUMÉRO D'ARTICLE + désignation de l'article\ANNÉE\BLXXXX\"

Pour pouvoir enregistrer les pièces jointes, le programme doit avant :

1- Trouver le dossier "C:\Documents\CONTRAT\FOURNISSEURS\NUMÉRO D'ARTICLE + Libellé de l'article"
sachant que je n'ai que le numéro d'article dans l'objet (qui est unique à chaque article) et vérifier que le dossier existe bien (sinon on affiche un message d'erreur stipulant que l'article n'existe pas)

2 -Il doit ensuite vérifier que le dossier ANNÉE existe, sinon le programme doit créer un nouveau dossier ANNÉE

3 -Il doit ensuite vérifier que le dossier BLXXXX existe, sinon le programme doit créer un nouveau dossier BLXXXX

4 -Une fois que toutes ces actions sont effectuées, il pourra enfin enregistrer les pièces jointes.

Je n'arrive pas à effectuer ma fonction recherche (1er point) sur la recherche du dossier "...\NUMÉRO D'ARTICLE + Libellé de l'article\".

Pourriez-vous m'indiquer si la démarche est bonne ?

Merci d'avance pour les réponses apportées.
Vous trouverez ci-joint la synoptique du programme que j'ai effectué

Cordialement,

Théo

**Oliv-** · 22/12/2016, 14h11

Bonjour,

Tu trouveras là un exemple de code pour trouver un emplacement de fichier ou le créer (waaps_creedir) sur le disque et un exemple pour enregistrer un Email
http://www.developpez.net/forums/blo...le-disque-msg/

par contre il faudra le modifier

pour scinder une chaine comme celle-ci :
"CONTRAT\FOURNISSEURS\NUMÉRO D'ARTICLE \ANNÉE\BLXXXX"

tu dois utiliser split(machaine, "\")

pour tester la partie "NUMÉRO D'ARTICLE + Libellé de l'article"

il te faut arriver déjà dans le dossier supérieur, puis tester avec
instr(1,dossier,BLXXXX,vbTextCompare)>0 cela veut dire que le numéro est dans le libellé du dossier

Mais il faudrait quelques exemples réels pour ajuster le code

Ici un exemple pour enregistrer des PJ
http://www.developpez.net/forums/blo...yperlien-mail/

**theolerouleau** · 23/12/2016, 10h33

Merci beaucoup pour ta réponse.
Cependant, je ne vois pas comment arriver au dossier supérieur pour ce qui est de la recherche du dossier "NUMÉRO D'ARTICLE + Libellé de l'article".

Voici le code que j'ai commencé à élaborer, qui est soit dit en passant un peu simpliste. J'espère que vous pardonnerez mon manque de connaissances, je suis en pleine auto-formation.

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
Public Sub SaveAttachement(Item As Outlook.MailItem)
        Dim attachs As Variant
        Dim attach As Variant
        Dim file As Variant
        Dim objetdumail As Variant
        Dim repertoire As String
        Dim NomExport As String
 
 
        NomExport = Item.Subject
        objetdumail = Split(NomExport, "\")
        repertoire = "C:\User\mtheo\Desktop\Fludification CQA\"
        If objetdumail > 4 Then repertoire = repertoire & objetdumail(0) & objetdumail(1)
 
'__________________SUITE DES ETAPES___________________'
 
'ETAPE 1 : TROUVER LE DOSSIER Numéro d'article + désignation (objetdumail(2)
 
'ETAPE 2 : Appeler le programme waaps_creedir pour trouver ou créer les 2 derniers dossiers
 
'SAUVEGARDE DES PIECES JOINTES
 
        Set attachs = Item.Attachments
        For Each attach In attachs
            file = attach.FileName
            attach.SaveAsFile repertoire & "\" & objetdumail(2) & "\" & objetdumail(3) & "\" & file '<=== c:\ correspond au dossier dans lequel vous voulez sauvegarder les pièces jointes
        Next
 
End Sub

Bonne journée à tous

**Oliv-** · 23/12/2016, 12h09

Si j'ai bien compris ceci devrait fonctionner

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
 
 
Public Sub SaveAttachement(Item As Outlook.MailItem)
    Dim attachs As Variant
    Dim attach As Variant
    Dim file As Variant
    Dim objetdumail As Variant
    Dim repertoire As String
    Dim NomExport As String
 
 
    NomExport = Item.Subject
    objetdumail = Split(NomExport, "\")
    repertoire = "C:\User\mtheo\Desktop\Fludification CQA\"
    If objetdumail > 4 Then repertoire = repertoire & objetdumail(0) & objetdumail(1)
 
    '__________________SUITE DES ETAPES___________________'
 
    'ETAPE 1 : TROUVER LE DOSSIER Numéro d'article + désignation (objetdumail(2)
 
    'ETAPE 2 : Appeler le programme waaps_creedir pour trouver ou créer les 2 derniers dossiers
 
 
    chemin = GetDossierBL(NomExport)
    If chemin = "" Then 
       MsgBox "Le dossier [" & Sujet & "] n'existe pas"
       exit sub
        End If
    End Sub
 
    'SAUVEGARDE DES PIECES JOINTES
 
    Set attachs = Item.Attachments
    For Each attach In attachs
        file = attach.Filename
        attach.SaveAsFile chemin & "\" & file    '<=== c:\ correspond au dossier dans lequel vous voulez sauvegarder les pièces jointes
    Next
 
End Sub
 
Sub TestGetDossierBL()
    Dim Sujet As String
    Dim chemin As String
    Sujet = "CONTRAT\FOURNISSEURS\123456\2016\BLXXXX"
    'Sujet = "CONTRAT\TOTO\123456\2016\BLXXXX"
 
    chemin = GetDossierBL(Sujet)
    If chemin <> "" Then
        MsgBox chemin
    Else
        MsgBox "Le dossier [" & Sujet & "] n'existe pas"
        End If
    End Sub
Function GetDossierBL(Sujet As String) As String
 
    Dim aSujet As Variant
    Dim repertoireTrouve As String
    GetDossierBL = ""
 
    repertoireBase = "C:\User\mtheo\Desktop\Fludification CQA\"
    'repertoireBase = "e:\temp\mtheo\"
 
    aSujet = Split(Sujet, "\")
    'on recompose le chemin connu
 
    repertoire = repertoireBase + aSujet(0) + "\" + aSujet(1)
    NumArticle = aSujet(2)
    Année = aSujet(3)
    BL = aSujet(4)
    LibelléArticle = "?"
 
    Dim FSO As Object, oDossier
    Set FSO = CreateObject("Scripting.filesystemobject")
    If FSO.FolderExists(repertoire) Then
        Set oDossier = FSO.getfolder(repertoire)
 
        For Each oSubFolder In oDossier.SubFolders
 
            If InStr(1, oSubFolder.Name, NumArticle, vbTextCompare) > 0 Then
                LibelléArticle = oSubFolder.Name
                repertoireTrouve = oSubFolder.path
                'on cherche l'année et le BL et on crée les dossiers si ils n'existent pas
                If waaps_creedir(repertoireTrouve & "\" & Année & "\" & BL) Then GetDossierBL = repertoireTrouve & "\" & Année & "\" & BL
 
                Exit For
            End If
        Next oSubFolder
 
    Else
        GetDossierBL = ""
    End If
 
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
 
    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