Mike asks:
I need code that will loop through each cell in a column and for each e-mail address search the inbox and save the e-mail and all attachments to a particular folder on a shared drive.
Then I would require the saved files and attachments to be hyperlinked in to a cell in the row for that e-mail address.
Dim rCell As Range
Dim vaFileNames() As Variant
Dim i As Long
‘Loop through column B
For Each rCell In Intersect(Sheet1.UsedRange, Sheet1.Columns(2)).Cells
‘Check if it’s an email address
If rCell.Value2 Like “*@*.*” Then
ReDim vaFileNames(1 To 1)
SaveEmail rCell.Value2, vaFileNames
‘Create hyperlinks for all files saved
If Not IsEmpty(vaFileNames(1)) Then
For i = LBound(vaFileNames) To UBound(vaFileNames)
Sheet1.Hyperlinks.Add rCell.Offset(0, i), vaFileNames(i), , , Dir(vaFileNames(i))
Next i
End If
End If
Next rCell
End Sub
Sub SaveEmail(sFrom As String, ByRef vaFileNames() As Variant)
Dim olApp As Outlook.Application
Dim olFldr As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olAtt As Outlook.Attachment
Dim sPath As String
Dim lFileCnt As Long
Dim sFile As String
sPath = Environ(“USERPROFILE”) & “My DocumentsInboxStuff”
Set olApp = New Outlook.Application
Set olFldr = olApp.GetNamespace(“MAPI”).GetDefaultFolder(olFolderInbox)
For Each olMail In olFldr.Items
If olMail.SenderEmailAddress = sFrom Then
sFile = sPath & CleanFile(olMail.Subject) & “.txt”
olMail.SaveAs sFile, olTXT
AddFileToList sFile, lFileCnt, vaFileNames
For Each olAtt In olMail.Attachments
sFile = sPath & “” & olAtt.Filename
olAtt.SaveAsFile sFile
AddFileToList sFile, lFileCnt, vaFileNames
Next olAtt
End If
Next olMail
Set olFldr = Nothing
Set olApp = Nothing
End Sub
Sub AddFileToList(sFile As String, ByRef lFileCnt As Long, ByRef vaFileNames() As Variant)
lFileCnt = lFileCnt + 1
ReDim Preserve vaFileNames(1 To lFileCnt)
vaFileNames(lFileCnt) = sFile
End Sub
Function CleanFile(sFile As String) As String
Dim i As Long
Dim vIllegals As Variant
Dim sReturn As String
vIllegals = Array(“/”, “”, “:”, “*”, “?”, “< “, “>”, “|”, “”“”)
sReturn = sFile
For i = LBound(vIllegals) To UBound(vIllegals)
sReturn = Replace(sReturn, vIllegals(i), “_”)
Next i
CleanFile = sReturn
End Function
If you want to run this code, for goodness sake make a backup of your workbook. This code writes hyperlinks into cells and doesn’t care what it deletes. Make sure you set a reference to the Microsoft Outlook Type Library (VBE – Tools – References). Other things to change: it looks in column B for email address, it looks on and writes to Sheet1. You’ll need to adjust sPath and make sure that folder exists. Adjust those factors to suit your situation.
The CleanFile function was adapted from the comments to this post. I might need something more robust to determine if a cell contains a valid email address, but what I have seems to work. The worst that would happen is that it would pick up an invalid one and not find anything.
It may be different if manipulating email attachments from Excel but there’s a potential problem looping through multiple attachments on an email.
In his website (http://www.slovaktech.com) Ken Slovak (Outlook MVP) explains:
“Use a count down loop for removing items from a collection. Otherwise, the loop counter gets confused and only every other item is removed.”
For c = Item.Attachments.Count To 1 Step -1
…
I love this code. It’s just what I need at work. I nearly adore it!
It works great for all emails in my inbox from external email addresses such as joe.bloggs@wherever.com.
It won’t work for me for any emails from internal email addresses.
I looked at the SenderEmailAddress property of all the emails in my inbox, which turns out to be joe.bloggs@wherever.com for external messages but /O=MY COMPANY/OU=FIRST ADMINISTRATIVE GROUP/CN=RECIPIENTS/CN=JOE.BLOGGS for internal messages.
I can’t find a way round this. Am I missing something?
A life saver indeed; but experiencing same issue as auger33. It does not recognize internal email addresses…
I’ve never seen email address like that. And whenever I say that, it always means Exchange Server.
What do you guys have in column B and what would be a match in SenderEmailAddress? I think we could piece together an email out of that long string that matches. I’m not sure where that string is defined, but I’m sure it’s out there somewhere. So does
joe.bloggs@yourcompany.com always equal /O=yourcompany/OU=FIRST ADMINISTRATIVE GROUP/CN=RECIPIENTS/CN=JOE.BLOGGS
Found this function while googling (credit to Ashihs). Havent tested this yet, but it seems it might solve Auger and mine little issue with exchange email addresses..
Dim strEntryID As String
Dim strStoreID As String
Dim objSession As MAPI.Session
Dim objCDOItem As MAPI.Message
‘ get EntryID and StoreID for message
strEntryID = objMsg.EntryID
strStoreID = objMsg.Parent.StoreID
‘ start CDO session
Set objSession = CreateObject(“MAPI.Session”)
objSession.Logon , , False, False
‘ pass item to CDO and get sender address
On Error Resume Next
Set objCDOItem = objSession.GetMessage(strEntryID, strStoreID)
SenderFromAddress = objCDOItem.Sender.Address
‘ Check to see if the address is a Microsoft Exchange email address
If Left(SenderFromAddress, 3) = “/o=” Then
‘ Local variables
Dim senderAddress() As String
Dim strLength As Integer
Dim i As Integer
Dim username() As String
Dim temp As Integer
Dim sendersEmail As String
‘ Get length of MS Exchange string
strLength = Len(SenderFromAddress)
‘ Parse thru the string and insert into array
For i = 0 To strLength
ReDim Preserve senderAddress(i)
senderAddress(i) = Mid$(SenderFromAddress, i, 1)
Next i
‘ Get to the username at the end of the string.
‘ I started from 55 because that is where the first letter of the username
‘ in my string started, yours might be different.
‘ Ubound(senderAddress) gets you to the index of the last letter in the username
‘ Finally extract the username and concatenate it into a string literal
For i = 55 To UBound(senderAddress)
Dim j As Integer
sendersEmail = sendersEmail + senderAddress(i)
Next i
‘ Create the full email address for display
SenderFromAddress = sendersEmail + “@yourdomain.com”
Set objSession = Nothing
Set objCDOItem = Nothing
End If
End Function
My apologies for not posting within code tags.. Would be careful next time.
No problem – fixed. Thanks for finding and posting that code. I can’t say I really understand it, though. Here’s how I would do it if all my assumptions about Exchange sender strings if correct:
Dim lLastCn As Long
Const sCN As String = “/CN=”
Const sDOMAIN As String = “@mycompany.com”
If UCase(Left$(sSender, 3)) = “/O=” Then
lLastCn = InStrRev(sSender, sCN)
If lLastCn > 0 Then
GetSenderAddress = Mid$(sSender, lLastCn + Len(sCN), Len(sSender)) & sDOMAIN
Else
GetSenderAddress = sSender
End If
Else
GetSenderAddress = sSender
End If
End Function
called like
GetSenderAddress(olMail.SenderEmailAddress)Assumptions are: the email address is always last and it's always preceded by /CN=
Thanks dk and Dick. It now works perfectly on my work system.