Consulting

Page 2 of 2 FirstFirst 1 2
Results 21 to 40 of 40

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

  1. #21
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  2. #22
    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

  3. #23
    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

  4. #24
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #25
    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!!

  6. #26
    Which folder does not exist?
    What is the full path of the folder that 'does not exist'?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #27
    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.
    Last edited by nathandavies; 03-31-2017 at 01:33 AM. Reason: additional information

  8. #28
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  9. #29
    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

  10. #30
    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
    Last edited by nathandavies; 03-31-2017 at 05:40 AM. Reason: updated code to suit

  11. #31
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  12. #32
    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

  13. #33
    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\"
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  14. #34
    Graham! you my friend are a genius!!

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

    REP ADDED!

    Cheers
    ND

  15. #35
    VBAX Newbie
    Joined
    Sep 2019
    Posts
    3
    Location
    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
    Last edited by Fredjo; 09-04-2019 at 02:13 AM. Reason: forum restrictions, trying to find them :)

  16. #36
    Quote Originally Posted by Fredjo View Post
    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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  17. #37
    VBAX Newbie
    Joined
    Sep 2019
    Posts
    3
    Location
    Done. Thanks Graham.

  18. #38
    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.

  19. #39
    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.

  20. #40

    Help

    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
    Last edited by Big_online; 03-10-2020 at 10:08 AM. Reason: more info

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •