The following will create unique messages from Inbox in the folder indicated in column B of the worksheet that relate to the e-mail address in column A from rows 1 to 10.
The folder must be a complete folder path which will be created if not already present e.g. C:\Path\Foldername\
Option Explicit
Sub SearchEmails()
Dim oExcel As Object
Dim oWorkbook As Object
Dim oWorksheet As Object
Dim oRange As Object
Dim oItem As Object
Dim sEmail As String
Dim sPath As String
Dim sName As String
Dim sSpreadsheet As String
Dim sFilter As String
Dim oMail As MailItem
'Specify the path to the spreadsheet 'For example: "C:\Users\Bob\Documents\Emails.xlsx"
sSpreadsheet = "S:\Marshall Wu\test file.xlsx"
'Create an instance of Excel and open the spreadsheet
Set oExcel = CreateObject("Excel.Application")
Set oWorkbook = oExcel.Workbooks.Open(sSpreadsheet)
Set oWorksheet = oWorkbook.Worksheets(1)
oExcel.Visible = True
'Get the range of cells you want to read from 'For example: "A1:A10"
Set oRange = oWorksheet.Range("A1:A10")
'Loop through the cells in the range
For Each oItem In oRange.cells
'Read the email address and file path from the cells
sEmail = oItem.Value
sPath = oItem.Offset(0, 1).Value
Do Until Right(sPath, 1) = "\"
sPath = sPath & "\"
Loop
'Print the values of sEmail and sPath to the immediate window
'Debug.Print "Email: " & sEmail & ", Path: " & sPath
'Build the search filter
sFilter = "[SenderEmailAddress] = '" & sEmail & "'"
'Search the mailbox for emails from the specified sender
For Each oMail In Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items.Restrict(sFilter)
'Save the email to the specified folder
sName = CleanFileName(oMail.Subject)
SaveUnique oMail, sPath, sName
Next
Next
'Close the spreadsheet and quit Excel
lbl_Exit:
oWorkbook.Close
oExcel.Quit
Set oWorkbook = Nothing
Set oExcel = Nothing
Set oWorksheet = Nothing
Set oItem = Nothing
Set oMail = Nothing
Exit Sub
End Sub
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
'Ensures that filenames are not overwritten
Dim lngF As Long
Dim lngName As Long
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
lngF = 1
lngName = Len(strFileName)
Do While FSO.FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
CreateFolders strPath
oItem.SaveAs strPath & strFileName & ".msg" '".txt", olTXT
lbl_Exit:
Exit Function
End Function
Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lng_PathSep = InStr(3, strPath, "\")
If lng_PathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
If lng_PathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lng_PathSep = 0
If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
oFSO.CreateFolder Left(strPath, lng_PathSep)
End If
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub
Private Function CleanFileName(strFileName As String) As String
Dim arrInvalid() As String
Dim lng_Index As Long
'Define illegal characters (by ASCII CharNum)
arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
'Remove any illegal filename characters
CleanFileName = strFileName
For lng_Index = 0 To UBound(arrInvalid)
CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
Next lng_Index
lbl_Exit:
Exit Function
End Function