Create folders for attachments based on sender name

Question

Students email answers to assessments and I put them in folders relating to the assessment number. There may be multiple emails from a student holding differing attachments for that assessment, as they complete them.

I have a main folder under my Inbox called AllNZBAT. I have sub folders of assessment numbers. 112, 123, 2785 etc. for student's emails.

I need to extract the student's attachments from multiple emails and put them in a folder with the students name (sender) in the folder for that assessment.

So Folder "John Smith" holds all his attachments for assessment 123.

I am trying to write a macro that does this. It creates the folder tree and the folder with the student's name. I can't get the attachments in a folder with the sender's name.

Sometimes I get two folders with the same student's name but one folder will also have (Unicode Encoding Conflict) after the name.

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim myNewFolder As Outlook.Folder
Dim currentFolder As Outlook.Folder

'https://www.codeproject.com/Questions/5258321/Outlook-VBA-automatically-create-a-folder-based-on
'https://vbatutorialcode.com/save-all-attachments-from-outlook-into-folder-vba/
'https://stackoverflow.com/questions/15531093/save-attachments-to-a-folder-and-rename-them

Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem

Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("All NZBat")  'set the start folder - replace it with selection

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")

Dim FoldersArray As Variant
Dim LastFolder As Integer
Dim strParentFolderName As String

'use to create the folders on the drive
Dim fs As Object 'Using late binding to avoid having to include a reference to Microsoft Scripting Runtime
Set fs = CreateObject("Scripting.FileSystemObject")

'C:\Dropbox\NZBAT Resources\112FebStudetnResults
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)

On Error Resume Next

'get all the folders under the All NZBat
For Each Folder In olFolder.Folders
  ' Debug.Print Folder.FolderPath    '\\*****@*****.ac.nz\Inbox\All NZBat\112
   
 Set currentFolder = Folder
     FoldersArray = Split(Folder.FolderPath, "\")
     LastFolder = UBound(FoldersArray)
     
     'Debug.Print FoldersArray(LastFolder) '112
     'get the last folder in the path string = 112 so we can make a new folder with its name
    strParentFolderName = FoldersArray(LastFolder)
    
'Next

'need to get all the emails in the folder

' Set the Attachment folder with the name of the sender.
strFolderpath = "C:\Dropbox\EmailedAssessments\" & strParentFolderName & "\"  ' & objMsg.SenderName & " \ "
 'Debug.Print strFolderpath  'C:\Dropbox\NZBAT Resources\112\
   '  strFolderpath = Replace(strFolderpath, " ", "_")
  'make the folder
    
    If Not fs.folderexists(strFolderpath) Then
        fs.createfolder (strFolderpath)
    End If



' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

'Set currentFolder = 'Application.ActiveExplorer.currentFolder

' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In currentFolder.Items  'objSelection

'Debug.Print objMsg.Subject
strFolderpathFull = strFolderpath & objMsg.SenderName & " \ "
 ' strFolderpathFull = Replace(strFolderpathFull, " ", "_")
 
 'Debug.Print strFolderpathFull  'C:\Dropbox\NZBAT Resources\112\Kathryn Tonks \
 
 ' Dim fs As Object 'Using late binding to avoid having to include a reference to Microsoft Scripting Runtime
  '  Set fs = CreateObject("Scripting.FileSystemObject")
    
    'make the subfolder
    If Not fs.folderexists(strFolderpathFull) Then
        fs.createfolder (strFolderpathFull)
    End If

    ' This code only strips attachments from mail items.
    ' If objMsg.class=olMail Then
    ' Get the Attachments collection of the item.
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    strDeletedFiles = ""

    If lngCount > 0 Then

        ' We need to 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 i = lngCount To 1 Step -1

            ' Save attachment before deleting from item.
            ' Get the file name.
            strFile = objAttachments.Item(i).FileName

            ' Combine with the path to the Temp folder.& StudentFolder
            strFile = strFolderpathFull & strFile
       '    strFile = Replace(strFile, "_\_", "\")
         
 
            ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile
           Debug.Print strFile & " Saved attachment"


            'write the save as path to a string to add to the message
            'check for html and use html tags in link
            If objMsg.BodyFormat <> olFormatHTML Then
                strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
            Else
                strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                strFile & "'>" & strFile & "</a>"
            End If

            'Use the MsgBox command to troubleshoot. Remove it from the final code.
            'MsgBox strDeletedFiles

        Next i

        ' Adds the filename string to the message body and save it
        ' Check for HTML body
        If objMsg.BodyFormat <> olFormatHTML Then
            objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
        Else
            objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
        End If
      
        
        g.Save
    End If
Next
Next
End Sub

Answer 1

Your code was really close to working (btw would not compile in the form it had been copied into the question)... but rather than fully debugging it, I took the approach of cleaning it up until it worked; there was a lot of code that was redundant.

The code below reads though all assignment folders/student folders and email messages ... and creates the assignment sub directories, and the student directories within those, and saves attachments within the assignment/student directory. It updates the email body with the references to the saved attachment(s).

If you wanted it work for only selected folders, you'll need to tweak the below code a bit.

I suspect that the issue with the duplicate directory names is possibly due to incompatible characters from the student's email address being put into the student's directory path name ... so I've included a very primitive cleaning function (which I didn't test all too much) to hopefully avoid that;it may need tweaking.

Incidentally, I use early binding so you'll need to add a reference to the MS scripting runtime if you don't already have it.

Option Explicit

Public Sub SaveAttachments()

    Const ParentDirectory = "C:\Dropbox\EmailedAssessments\"
    
    Dim fs As New FileSystemObject                          ' File system object
    Dim MAPINamspace As Outlook.NameSpace                   ' MAPI namespace
    Dim InboxFolder As folder                               ' Inbox
    Dim ParentFolder As folder                              ' Parent folder ... e.g. "ALL NZBAT"
    Dim AssignmentSubFolder As folder                       ' Assignment folders in Parent Folder
    Dim OutlookMessage As MailItem                          ' Outlook message
    Dim AssignmentDirectory As String                       ' Assignment Directory
    Dim StudentDirectory As String                          ' Student Directory (within Assignment Directory)
    Dim AttachmentPathFileName As String                    ' Attachment Path and File Name
    Dim DeletedAttachments As String                        ' A record of all deleted attachments to append to Outlook message
    Dim OutlookAttachment As Attachment                     ' Outlook attachment
    
    Set MAPINamspace = Outlook.Application.GetNamespace("MAPI")
    Set InboxFolder = MAPINamspace.GetDefaultFolder(olFolderInbox)
    Set ParentFolder = InboxFolder.Folders("ALL NZBAT")
    
    ' Get all the Outlook subfolders in the Parent Folder "ALL NZBAT"
    For Each AssignmentSubFolder In ParentFolder.Folders
        
        ' Setup the directory where each assignment's data will be saved
        AssignmentDirectory = ParentDirectory & AssignmentSubFolder.Name & "\"
        If Not fs.folderexists(AssignmentDirectory) Then
            fs.createfolder (AssignmentDirectory)
        End If
        
        ' Check each selected item for attachments. 
        For Each OutlookMessage In AssignmentSubFolder.Items
        
            ' Setup the directory where each student's attachments will be saved, cleaning (in a primitive way) the SenderName
            StudentDirectory = AssignmentDirectory & CleanName(OutlookMessage.SenderName) & "\"
            If Not fs.folderexists(StudentDirectory) Then
                fs.createfolder (StudentDirectory)
            End If
        
            ' Save all the attachments from the message
            DeletedAttachments = ""
            For Each OutlookAttachment In OutlookMessage.Attachments
                
                ' Save the attachment
                AttachmentPathFileName = StudentDirectory & OutlookAttachment.FileName
                OutlookAttachment.SaveAsFile AttachmentPathFileName
                
                ' Keep a record of the all the saved attachments.
                If OutlookMessage.BodyFormat <> olFormatHTML Then
                    DeletedAttachments = DeletedAttachments & vbCrLf & "<file://" & AttachmentPathFileName & ">"
                Else
                    DeletedAttachments = DeletedAttachments & "<br>" & "<a href='file://" & AttachmentPathFileName & "'>" & AttachmentPathFileName & "</a>"
                End If

            Next
        
            ' Append a record of all of the saved attachments to the start of the outlook message
            If DeletedAttachments <> "" Then
                If OutlookMessage.BodyFormat <> olFormatHTML Then
                    OutlookMessage.Body = vbCrLf & "The file(s) were saved to " & DeletedAttachments & vbCrLf & OutlookMessage.Body
                Else
                    OutlookMessage.HTMLBody = "<p>" & "The file(s) were saved to " & DeletedAttachments & "</p>" & OutlookMessage.HTMLBody
                End If
                OutlookMessage.Save
            End If
            
        Next
        
    Next
End Sub

Public Function CleanName(InputName As String) As String

    Dim Counter As Long
    Dim WorkChar As String
    
    ' A primitive file name cleaner
    For Counter = 1 To Len(InputName)
        WorkChar = Mid(InputName, Counter, 1)
        If Asc(WorkChar) <= 31 Or InStr(1, "<>:""/|?*", WorkChar) > 0 Then
            CleanName = CleanName & "_"
        Else
            CleanName = CleanName & WorkChar
        End If
    Next
    
End Function