Saving Emails from specific sender to folder on hard drive

[holley]

Hello all and many thanks for past help. Reaching out once because I am trying to create an Excel spreadsheet where I can add a button to launch a macro that will allow a way to save all the emails in the inbox from a specific sender - this is a shared mailbox- to a folder on a shared hard drive (P:\responses) I would like to create a subfolder with the current date and have the emails saved there. Access to creating and running macros is disabled within Outlook, but we can use them in Excel. Any assistance would be most appreciated in tackling this. Thanks again in advance!!

[georgiboy]

Hi holley,

You can give the below a try:

Sub SaveMSGs()
Dim olFolder As Folder
Dim olItem As MailItem
Dim iCount As Integer
Dim aPath As String, sPath As String
Dim fdObj As Object

aPath = "C:\Users\jbloggs\Desktop\test\" '<<< Change to suit
sPath = apth & Replace(Date, "/", ".") & "\"

Set fdObj = CreateObject("Scripting.FileSystemObject")
If Not fdObj.FolderExists(sPath) Then
fdObj.CreateFolder (sPath)
End If

Set olFolder = Session.PickFolder
For iCount = 1 To olFolder.Items.Count
Set olItem = olFolder.Items(iCount)
If olItem.Class = OlObjectClass.olMail Then
olItem.SaveAs sPath & ValidName(olItem.Subject) & ".msg"
End If
Next iCount

Set olItem = Nothing
Set olFolder = Nothing

MsgBox "Complete"
End Sub


Private Function ValidName(Arg As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
.Pattern = "[\\/:\*\?""<>\|]"
.Global = True
ValidName = .Replace(Arg, "")
End With
End Function