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 |
Partager