Outlook macro to save emails in a specific folder based on a msgbox popup

[gmayor]

I don't know if it is my cognitive process or your explanations, but the more you explain the more confusing your requirement becomes.
I don't know if you want the project name that contains the five digit code e.g. 'P1234' or whether you want the full path. The following will provide both.
strPath is the path to the customer - "\\NEWBENSON\Projects\drawings\Customer" - No end slash
fPath1 is the path of the project - "\\NEWBENSON\Projects\drawings\Customer\P1234 Liverpool Street Station\"
strProject is the project - "P1234 Liverpool Street Station"
I still don't know where you want the Correspondence folders - in the customer folder or the project folder - and I don't know what you want for the Excel part you highlighted, but all the options you have raised are available by using the appropriate variables.

Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\drawings\"

Private Function GetPath(strRootPath As String) As String
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strRootPath)
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder) & Chr(92)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function

Sub SaveItem(olItem As MailItem)
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Dim vProject As Variant
Dim strProject As String

    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
                      "The path will be created if it doesn't exist.", _
                      "Save Message")
    If fPath1 = "" Then
        MsgBox "User cancelled"
        GoTo lbl_Exit
    End If    
strPath = strRoot & fPath1
Debug.Print strPath
    CreateFolders strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"

    fPath2 = GetPath(strRoot & fPath1)
    If fPath2 = "" Then
        MsgBox "The ID entered does not exist"
        GoTo lbl_Exit
    End If
Debug.Print fPath2
    vProject = Split(fPath2, Chr(92))
    strProject = vProject(UBound(vProject) - 1)
Debug.Print strProject

'End 'Remove this line after testing the paths

    If olItem.sender Like "*@dbensoncontrols.co.uk" Then    'Looks for messages from you
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Sent\" & fname
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Received\" & fname
    End If
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, strPath, fname
    'CopyToExcel olItem, strPath    'The line goes here
lbl_Exit:
    Exit Sub
End Sub

[nathandavies]

Hi Graham, I'm wanting the correspondence folders in the project folder, which is how my code is working now. Everything with excel is working great. the customer name is working correctly as well this is searching for the correct folder. the only change is that i only want to search for the project folder based on the first 5 characters of the folder. IE "P1234" and not have to input the full folder name IE "P1234 Liverpool Street Station"

I have just tried your code above and this doesn't seem to be saving the email anywhere.

Option ExplicitPrivate Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
Sub SaveMessage()
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    If Not TypeName(olMsg) = "MailItem" Then
        MsgBox "Select a mail item!"
        GoTo lbl_Exit
    End If
    SaveItem olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub


Private Function GetPath(strRootPath As String) As String
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strRootPath)
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder) & Chr(92)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function
Sub SaveItem(olItem As MailItem)
    Dim fname As String
    Dim fPath1 As String, fPath2 As String
    Dim strPath As String
    Dim vProject As Variant
    Dim strProject As String
    Dim objItem As Outlook.MailItem
     
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
    "The path will be created if it doesn't exist.", _
    "Save Message")
    If fPath1 = "" Then
        MsgBox "User cancelled"
        GoTo lbl_Exit
    End If
    strPath = strRoot & fPath1
    Debug.Print strPath
    CreateFolders strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"
     
    fPath2 = GetPath(strRoot & fPath1)
    If fPath2 = "" Then
        MsgBox "The ID entered does not exist"
        GoTo lbl_Exit
    End If
    Debug.Print fPath2
    vProject = Split(fPath2, Chr(92))
    strProject = vProject(UBound(vProject) - 1)
    Debug.Print strProject
     
     'End 'Remove this line after testing the paths
     
    If olItem.Sender Like "Nathan Davies" Then 'Looks for messages from you
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
        Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Sent\" & fname
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
        Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Received\" & fname
    End If
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, strPath, fname
    CopyToExcel olItem, strPath
lbl_Exit:
 
     If MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?") = vbYes Then
            objItem.Delete
        End If


End Sub

[nathandavies]

Graham,

i have added a comment to the code so you can see exactly what i want to change.

thanks in advance.

Private Function GetPath() As String    Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strRoot)
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder) & Chr(92)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function


    Exit Sub
Sub SaveItem(olItem As MailItem)
    Dim fname As String
    Dim fPath1 As String, fPath2 As String
    Dim strPath As String
    Const fRootPath As String = "\\NEWBENSON\Projects\drawings\"
    Dim objItem As Outlook.MailItem
     
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
    "The path will be created if it doesn't exist.", _
    "Save Message")
    fPath1 = Replace(fPath1, "\", "")
     
    fPath2 = InputBox("Enter the project name and number.", "Save Message") 'THIS IS THE PART I WANT TO CHANGE TO LOOK FOR eg "P1234" WHICH IS THE GETPATH FUNCTION I BELIVE.
    fPath2 = Replace(fPath2, "\", "")
     
    strPath = fRootPath & fPath1 & "\" & fPath2
    CreateFolders strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"
     
    If olItem.Sender Like "Nathan Davies" Then
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
        Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Sent\" & fname
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
        Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Received\" & fname
    End If
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, strPath, fname
    CopyToExcel olItem, strPath 'The line goes here
lbl_Exit:
 
     If MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?") = vbYes Then
            objItem.Delete
        End If


End Sub

[gmayor]

I have already given you the GetPath function that does that. Call it from your code. I have not included below the other functions, that appear elsewhere in the thread, and which are called by this macro. They go below this code. i.e. Option Explicit is the first line of the module.

I have annotated the code where it might be helpful.

Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\drawings\"

Private Function GetPath() As String

    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strRoot)
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function

Sub SaveItem(olItem As MailItem)
Dim objItem As Outlook.MailItem
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
                      "The path will be created if it doesn't exist.", _
                      "Save Message")
    fPath1 = Replace(fPath1, "\", "")

    fPath2 = GetPath
    If fPath2 = "" Then
        MsgBox "The project number does not exist!"
        'so end processing
        GoTo lbl_Exit
    End If

    'fPath2 = Replace(fPath2, "\", "") 'superfluous as there is no backslash character in fpath2

    strPath = strRoot & fPath1 & "\" & fPath2
    'CreateFolders strPath 'superfluous as the following line will create strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"

    If olItem.sender Like "Nathan Davies" Then
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Sent\" & fname
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Received\" & fname
    End If
    'Remove illegal filename characters that might appear in the subject
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, strPath, fname
    'The CopyToExcel function earlier in the thread had only one named parameter
    CopyToExcel olItem
    If MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?") = vbYes Then
        objItem.Delete
    End If
lbl_Exit:
    Exit Sub
End Sub

[nathandavies]

Hi Graham,

For some reason i keep getting a message box saying Folder Does Not Exist but in fact to does exist. I have re-arranged my code like you mentioned above, but not sure why this would not find the folder now.

Thanks in advance for your help!!

[gmayor]

Which folder does not exist?
What is the full path of the folder that 'does not exist'?

[nathandavies]

all the folders exist as i'm using live files for testing,

this is the full path.

\\servername\Projects\Drawings\customer\P1711 Liverpool Street Station

I typed in the customer name correctly and the P1711, but straight away it came up with the error folder does not exist.

[gmayor]

I hate to say it, but you are right The GetPath function took no account of the customer name and was based on an earlier path that had the customer in the root path. You pass the customer name to the GetPath sunction (strCustomer) and include it with the root path when starting the search.

The following however should work: Replace the GetPath function with this one, and change the start of the main macro as shown below it.

Private Function GetPath(strCustomer As String) As String
     
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strroot & Chr(92) & strCustomer)
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function
 
Sub SaveItem(olItem As MailItem)
    Dim objItem As Outlook.MailItem
    Dim fname As String
    Dim fPath1 As String, fPath2 As String
    Dim strPath As String
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
    "The path will be created if it doesn't exist.", _
    "Save Message")
    fPath1 = Replace(fPath1, "\", "")
     
    fPath2 = GetPath(fPath1)
    If fPath2 = "" Then
        MsgBox "The project number does not exist!"
         'so end processing
        GoTo lbl_Exit
    End If
     
    strPath = fPath2
     
     'CreateFolders strPath 'superfluous as the following line will create strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"
  'Followed by the rest of the macro

[nathandavies]

I'm getting an error on the strRoot, not sure if it is because it is not defined so tried that and still did not work.

Private Function GetPath(strCustomer As String) As String     
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer) 'error on strRoot?
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function

[nathandavies]

Graham, i have solved the above issue. but it still will not save the email for some reason. i have put my updated code in for your assistance.

Option ExplicitPrivate Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
Private Function GetPath(strCustomer As String) As String
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer)
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function
 
Sub SaveItem(olItem As MailItem)
    Dim objItem As Outlook.MailItem
    Dim fname As String
    Dim fPath1 As String, fPath2 As String
    Dim strPath As String
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
    "The path will be created if it doesn't exist.", _
    "Save Message")
    fPath1 = Replace(fPath1, "\", "")
     
    fPath2 = GetPath(fPath1)
    If fPath2 = "" Then
        MsgBox "The project number does not exist!"
         'so end processing
        GoTo lbl_Exit
    End If
     
    strPath = fPath2
     
     'CreateFolders strPath 'superfluous as the following line will create strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"
     'Followed by the rest of the macro

[gmayor]

Regarding this and your other similar thread which relates to the attachments, The following is all the code required to achieve both aims in one operation. I have tested the code and it works here (albeit I have had to use a different network path). It certainly saves the messages (and their attachments separately) in the same folder..

I am beginning to wish I had never begun this

Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
 
Sub TestCode()
Dim olMsg As MailItem
    'On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveItem olMsg
lbl_Exit:
    Exit Sub
End Sub

Private Function GetPath(strCustomer As String) As String
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer) 'error on strRoot?
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function

Sub SaveItem(olItem As MailItem)
Dim objItem As Outlook.MailItem
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String, strSavePath As String
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
                      "The path will be created if it doesn't exist.", _
                      "Save Message")
    fPath1 = Replace(fPath1, "\", "")

    fPath2 = GetPath(fPath1)
    If fPath2 = "" Then
        MsgBox "The project number does not exist!"
        'so end processing
        GoTo lbl_Exit
    End If

    strPath = fPath2
    MsgBox strPath

    'CreateFolders strPath 'superfluous as the following line will create strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"

    'vProject = Split(fPath2, Chr(92))
    'strProject = vProject(UBound(vProject) - 1)
    'Debug.Print strProject

    If olItem.sender Like "*@dbensoncontrols.co.uk" Then    'Looks for messages from you
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        strSavePath = strPath & "\Correspondence\Sent\"
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        strSavePath = strPath & "\Correspondence\Received\"
    End If

    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, strSavePath, fname
    SaveAttachments olItem, strSavePath
    'CopyToExcel olItem, strPath    'The line goes here
lbl_Exit:
    Exit Sub
End Sub

Private Sub SaveAttachments(olItem As MailItem, strSaveFolder As String)
'An Outlook macro by Graham Mayor
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
    On Error GoTo CleanUp
    If olItem.Attachments.Count > 0 Then
        For j = olItem.Attachments.Count To 1 Step -1
            Set olAttach = olItem.Attachments(j)
            If Not olAttach.fileName Like "image*.*" Then
                strFname = olAttach.fileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(strSaveFolder, strFname, strExt)
                olAttach.SaveAsFile strSaveFolder & strFname
                'olAttach.Delete        'delete the attachment
            End If
        Next j
        olItem.Save
    End If
CleanUp:
    Set olAttach = Nothing
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
                                strFileName As String, _
                                strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Public Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
  If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  lngPathSep = InStr(3, strPath, "\")
  If lngPathSep = 0 Then GoTo lbl_Exit
  Set oFSO = CreateObject("Scripting.FileSystemObject")
  Do
    lngPS = lngPathSep
    lngPathSep = InStr(lngPS + 1, strPath, "\")
    If lngPathSep = 0 Then Exit Do
    If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
  Loop
  Do Until lngPathSep = 0
    If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
      oFSO.CreateFolder Left(strPath, lngPathSep)
    End If
    lngPS = lngPathSep
    lngPathSep = InStr(lngPS + 1, strPath, "\")
  Loop
lbl_Exit:
  Set oFSO = 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
    Dim lngF As Long
    Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function
 
Private Function FileExists(filespec As String) As Boolean
     'An Office macro by Graham Mayor - www.gmayor.com
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function
 
Private Function FolderExists(fldr As String) As Boolean
     'An Office macro by Graham Mayor - www.gmayor.com
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If (FSO.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Exit Function
End Function

[nathandavies]

Graham! That worked perfectly!! but is it possible to save the attachments in a different folder.

\Documents\Documents Received

I know you have done alot on this code already if its too much work then it is OK i understand!!

Thanks
ND

[gmayor]

You can save the attachments anywhere you like. The save function is called by the line

SaveAttachments olItem, strSavePath

at the bottom of the SaveItem macro
and strSavePath is currently the folder where the message is saved.
strPath is the folder relating to the customer. If \Documents\Documents Received\ is a sub folder of that folder then you need to add a line to Create that folder immediately below the other CreateFolders lines in the SaveItem macro
e.g.

CreateFolders strPath & "\Documents\Documents Received"

and then use that folder in the line at the top of this reply e.g.

SaveAttachments olItem, strPath & "\Documents\Documents Received\"

[nathandavies]

Graham! you my friend are a genius!!

Everything is now working perfectly thank you so much for the codes!!

REP ADDED!

Cheers
ND

[Fredjo]

Hello Graham,

This is my very post here and I'd like to thank you already for your work into this discussion.
Code in post #8 here (can't post links), is really what I need.

My problem is that my file structure is like this :
0001 - Customer 1
0002 - Customer 2
0003 - Customer 3
...

Your code is doing well but I don't want to write the customer name each time.. I'd like to enter the customer number and that's all.
Can you help me with this ?

I'm willing to donate some for the help, can you provide me with a link ?
Thank you already,
Fred

[gmayor]

can you provide me with a link ?
Fred

Contact me via my web site and explain what it is that you are trying to do and include the code that you are using.

[Fredjo]

Done. Thanks Graham.

[ksheck0810]

I came across this and was research a similar situation. However, as I tried to run the code, I noticed it is only saving one email at a time instead of an entire selection. Can you help with this where it will select multiple emails and save them to the designation folder? Also, how do you add a button that runs the macro automatically at the top of outlook? If you can help, I would greatly appreciate it.

[ksheck0810]

I came across this and was research a similar situation. However, as I tried to run the code, I noticed it is only saving one email at a time instead of an entire selection. Can you help with this where it will select multiple emails and save them to the designation folder? Also, how do you add a button that runs the macro automatically at the top of outlook? If you can help, I would greatly appreciate it.

[Big_online]

Thanks for help, this is very good,

Can you help me? can i change the code to save multiple selected emails to same folder?

Thanks

___________________________

Give me erro to post the code