Sauvegarder les pj d'un mails lorsqu'on l'ouvre et qu'il provient d'un expéditeur défini
Bonjour
Je pense que les réponses à mes questions existent dans la FAQ mais visiblement le serveur à un problème je tombe systématiquement que la page 403 Forbidden!
Je voudrais afin sauvegarder les pj d'un email mais seulement si le mail provient d'une adresse mail spécifique et connue, ouvrir un userform.
Ce userfom me proposerait alors:
soit de sauvegarder la pj dans un répertoire donné(on écrase si la pj est deja existante dans le répertoire)
soit de ne pas sauvegarder cette pj
et
de supprimer ou de sauvegarder le mail aprés sauvegarde ou pas de la pj.
pour le moment j'ai trouvé sur le forum comment déclencher la macro a l'ouverture du mail mais après je coince...
Code:
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 WithEvents AM As MailItem 'Attention cette ligne doit être avant les sub!
Private Sub Application_ItemLoad(ByVal Item As Object)
'se déclenche à la selection du mail
' Vérifis que le formulaire est bien celui d'un MAIL
If Item.Class <> olMail Then Exit Sub
Set AM = Item
End Sub
Private Sub AM_Open(Cancel As Boolean)
' se déclenche à l'ouverture du Mail mais également lors de la création d'un mail..
If AM.SenderName = "TOTO" Then 'en attendant de pouvoir récupérer l'adresse mail...
MsgBox "Ouverture de " & AM.Subject
End If
End Sub |
Bonne journée à tous et merci.
Une solution (peut-être) pour Outlook 2010 et Excel 2010
Bonjour,
Je recupere des donnees venant une installation PV via courriel (qd je ne suis pas sur suite).
Apres quelques efforts, j'ai fait deux procedures pour lire les courriels et afficher/ranger les attachements (un texte zip) dans un dossier utilisateur sous Win7, l'une dans l'application OutLook (avec une règle outlook et un sub lancé 'a la main' par l'opérateur ); l'autre dans une application complete sous Vba Excel.
Il semble que les deux modèles-objet aient quelques subtiles différences, qui expliquent une difference de programmation mais les deux solutions sont operationnelles. Je n'ai pas developpé le contexte mais assez facile à comprendre.
Code:
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
| OutLook (juste pour voir) :
Sub test()
Dim myOlApp As New Outlook.Application
DisplayAccountInformation myOlApp
End Sub
Private Sub DisplayAccountInformation(ByVal Application As Outlook.Application)
Dim myFolder As folder
Dim MsgTxt As String
Dim myItem As Outlook.MailItem
Set myFolder = Application.ActiveExplorer.Session.folders("Donnees_Courriel")
For Each myItem In myFolder.Items
MsgTxt = myItem.SenderName & " to " & myItem.To & vbCrLf & myItem.Subject
If Not myItem.Attachments.Count = 0 Then
For y = 1 To myItem.Attachments.Count
Set pceJointe = myItem.Attachments(y)
'pceJointe.SaveAsFile "C:\" & x & "_" & pceJointe
If pceJointe.FileName Like "*xml" Then
x = x + 1
pceJointe.SaveAsFile "C:\MonDossier\" & x & "_" & pceJointe.FileName
Else
If pceJointe.FileName Like "*txt" Then
MsgTxt = MsgTxt & vbCrLf & " --> " & pceJointe.FileName
End If
End If
Set pceJointe = Nothing
Next y
End If
MsgBox MsgTxt
Next
Exit Sub
End sub |
Excel (plus complet)
Code:
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
| ' ---
' Extraction de pieces jointes de courriel repondant a un critere de selection sur l'objet
' ---
'
Sub SaveAttachments( _
ByVal strTargetFolder As String, _
ByVal pDate As String, _
Optional ByVal blnIncludeSubFolders As Boolean = False)
Dim MsgTxt As String
' Dim myFolder As Folder
Dim olApp As Outlook.Application
Dim myItem As Outlook.MailItem
Dim myFolder As Outlook.Folder
Dim olExplorer As Outlook.Explorer
Dim xTrouve As Boolean
xTrouve = False
Set olApp = New Outlook.Application
Set olExplorer = olApp.Explorers(1)
Set olsession = olExplorer.Session
'Set myFolder = Application.ActiveExplorer.Session.Folders("Donnees_Courriel")
Set myFolder = olExplorer.Session.Folders("Donnees_Courriel")
For Each myItem In myFolder.Items
MsgTxt = myItem.SenderName & " to " & myItem.To & vbCrLf & myItem.Subject
If myItem.Subject Like "*" & pDate Then
If Not myItem.Attachments.Count = 0 Then
For y = 1 To myItem.Attachments.Count
Set pceJointe = myItem.Attachments(y)
If pceJointe.Filename Like "*xml" Then
x = x + 1
pceJointe.SaveAsFile strTargetFolder & x & "_" & pceJointe.Filename
Else
If pceJointe.Filename Like "*.zip.txt" Then
MsgTxt = MsgTxt & vbCrLf & " --> " & pceJointe.Filename
pceJointe.SaveAsFile strTargetFolder & pceJointe.Filename
xTrouve = True
End If
End If
Set pceJointe = Nothing
Next y
End If
End If
Next
If Not xTrouve Then
MsgTxt = MsgTxt & vbCrLf & "Pas d'attachement '.txt' joint"
End If
MsgBox MsgTxt, , "lecture des attachements du courriel"
End Sub |
Bonne utilisation
Cordialement
JFG
