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