Visual Basic Macro for Outlook

Good Morning,

The code below will look for at incoming emails and create a folder in desired location for each attachment automatically. It names the folders whatever the attached file is but i actually need it to label the folders with the name of the sender.

Example, if i get an email with an attachment from joeshoem@thecompany.com i want the script to create a folder called thecompany and save the attached file in that folder. That's the ultimate gold but i can settle with joeshoem@thecompany.com as the folder name as well.

Code:

---

Sub SaveAttachments_VariableFolder(MyMail As MailItem)

Dim Atmt As attachment

Dim FileName As String
Dim lenName As Long
Dim strPathAdd As String

Const strPath As String = "C:\test\" ' set as desired

On Error Resume Next
MkDir strPath
On Error GoTo 0

For Each Atmt In MyMail.Attachments

    If (Right(Atmt, Len(Atmt) - InStrRev(Atmt, "."))) = "pdf" Then
   
        lenName = InStrRev(Atmt, ".") - 1
           
        ' Trim possible spaces before the extension.
        ' A space at the end of the name created a problem with deleting the folder
        strPathAdd = strPath & Trim(Left(Atmt, lenName)) & "\"
           
        On Error Resume Next
        MkDir strPathAdd
        On Error GoTo 0

        FileName = strPathAdd & Atmt.FileName
        Atmt.SaveAsFile FileName
       
    End If
   
Next Atmt

Set Atmt = Nothing
   
End Sub

---

Check to see IF the directory already exists. Making a new one will fail a second time. Also, RESUME NEXT is not a good way to trap errors. It tends to HIDE them. Trap for a specific error, and then another...