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
| Sub IMPORT_PROFIL_EXTERNE()
Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.Namespace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.Attachment
Dim outItem As Object
Dim saveFolder As String
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String
Application.EnableEvents = False
Application.DisplayAlerts = False
saveFolder = Sheets("MENU").Range("J6") ' THIS IS WHERE YOU WANT TO SAVE THE ATTACHMENT TO
doszip = Sheets("MENU").Range("J6")
dosfile = Sheets("MENU").Range("J3")
subjectFilter = ("PROFIL EXTERNE") ' THIS IS WHERE YOU PLACE THE EMAIL SUBJECT FOR THE CODE TO FIND
OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set outApp = New Outlook.Application
OutlookOpened = True
End If
On Error GoTo 0
If outApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
Exit Sub
End If
Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.GetDefaultFolder(olFolderInbox)
If Not outFolder Is Nothing Then
For Each outItem In outFolder.Items
If outItem.Class = Outlook.OlObjectClass.olMail Then
Set outMailItem = outItem
For Each outAttachment In outMailItem.Attachments
If Right(outAttachment.Filename, 4) <> ".csv" Then GoTo line1:
outAttachment.SaveAsFile dosfile & outAttachment.Filename
datej = Format(FileDateTime(dosfile & outAttachment.Filename), "yyyy-mm-dd_HH-MM")
FileCopy dosfile & outAttachment.Filename, dosfile & datej & "_" & outAttachment.Filename
Kill dosfile & outAttachment.Filename
line1:
Next
Set outAttachment = Nothing
End If
Next
End If
If OutlookOpened Then outApp.Quit
Set outApp = Nothing
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub |
Partager