outlook : automatic download linked documents - vba

Question

a server sends me emails with a link file in each email.
Do you knwow if it exists a VBA code which opens each email, download each link file in a local directory, and move the email in another directory (as done) ?
Thanks a lot for your reply.
Christophe

Answer 1

If you want to download emails from Outlook, you can try this script.
Option Explicit On
Const fPath As String = "C:\Users\your_path_here\" 'The path to save the messages
Sub Download_Outlook_Mail_To_Excel()
Dim olApp As Object
Dim olFolder As Object
Dim olNS As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim NextRow As Long
Dim i As Long
Dim olItem As Object
Set xlBook = Workbooks.Add
Set xlSheet = xlBook.Sheets(1)
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err() <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
With xlSheet
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Subject"
.Cells(1, 3) = "Date"
'.Cells(1, 4) = "Size"
.Cells(1, 5) = "EmailID"
.Cells(1, 6) = "Body"
CreateFolders fPath
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
For Each olItem In olFolder.Items
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If olItem.Class = 43 Then
.Cells(NextRow, 1) = olItem.Sender
.Cells(NextRow, 2) = olItem.Subject
.Cells(NextRow, 3) = olItem.SentOn
'.Cells(NextRow, 4) =
.Cells(NextRow, 5) = SaveMessage(olItem)
'.Cells(NextRow, 6) = olItem.Body 'Are you sure?
End If
Next olItem
End With
MsgBox "Outlook Mails Extracted to Excel"
lbl_Exit:
Set olApp = Nothing
Set olFolder = Nothing
Set olItem = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Sub
End Sub
Function SaveMessage(olItem As Object) As String
Dim Fname As String
Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) &
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.sendername & " - " & olItem.Subject
Fname = Replace(Fname, Chr(58) & Chr(41), "")
Fname = Replace(Fname, Chr(58) & Chr(40), "")
Fname = Replace(Fname, Chr(34), "-")
Fname = Replace(Fname, Chr(42), "-")
Fname = Replace(Fname, Chr(47), "-")
Fname = Replace(Fname, Chr(58), "-")
Fname = Replace(Fname, Chr(60), "-")
Fname = Replace(Fname, Chr(62), "-")
Fname = Replace(Fname, Chr(63), "-")
Fname = Replace(Fname, Chr(124), "-")
SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
Exit Function
End Function
Private Function SaveUnique(oItem As Object,
strPath As String,
strFileName As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
SaveUnique = strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function
Private Sub CreateFolders(strPath As String)
Dim strTempPath As String
Dim iPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For iPath = 1 To UBound(vPath)
strPath = strPath & vPath(iPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next iPath
End Sub
Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFolder
nAttr = GetAttr(PathName)
If (nAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Now, let's say you want to download emails and save each individual text files, run this script.
Public Sub ProcessInbox()
Dim oOutlook As Outlook.Application
Dim oNs As Outlook.NameSpace
Dim oFldr As Outlook.MAPIFolder
Dim oAttachments As Outlook.Attachments
Dim oAttachment As Outlook.Attachment
Dim iMsgCount As Integer
Dim oMessage As Outlook.MailItem
Dim iCtr As Long, iAttachCnt As Long
Dim sFileNames As String
Dim aFileNames() As String
'get reference to inbox
Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")
Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
Debug.Print "Total Items: "; oFldr.Items.Count
Debug.Print "Total Unread items = " & oFldr.UnReadItemCount
For Each oMessage In oFldr.Items
With oMessage
'basic info about message
Debug.Print.To
Debug.Print.CC
Debug.Print.Subject
Debug.Print.Body
If .UnRead Then
Debug.Print "Message has not been read"
Else
Debug.Print "Message has been read"
End If
iMsgCount = iMsgCount + 1
'save message as text file
.SaveAs "C:\message" & iMsgCount & ".txt", olTXT
'reference and save all attachments
With oMessage.Attachments
iAttachCnt = .Count
If iAttachCnt > 0 Then
For iCtr = 1 To iAttachCnt
.Item(iCtr).SaveAsFile "C:\Users\your_path_here\" & .Item(iCtr).FileName
Next iCtr
End If
End With
End With
DoEvents
Next oMessage
Set oAttachment = Nothing
Set oAttachments = Nothing
Set oMessage = Nothing
Set oFldr = Nothing
Set oNs = Nothing
Set oOutlook = Nothing
End Sub
You can read all about these techniques, and many, many, many more things, in my book.
https://www.amazon.com/Automating-Business-Processes-Reducing-Increasing-ebook/dp/B01DJJKVZC/ref=sr_1_1?ie=UTF8&qid=1468466759&sr=8-1&keywords=ryan+shuell