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

Hi All,

I found a macro online which I’m trying to use to save the email to a folder within a specified directory. The folders are numbers either 4 or 5 digits like 5100 for example.

The macro isn’t finding the destination folder, even when I’ve changed it to c:\test and created a folder etc and tried different network directories.

Any ideas?

Code:

---

Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean
    ' Returns True if the passed sPathName exist Otherwise returns False
    On Error Resume Next
    If sPathName <> "" Then
        If IsMissing(Directory) Or Directory = False Then
            File_Exists = (Dir$(sPathName) <> "")
        Else
            File_Exists = (Dir$(sPathName, vbDirectory) <> "")
        End If
    End If
End Function
 
Sub SaveAsMSG()
    Dim myItem As Outlook.Inspector
    Dim objItem As Object
    PathName = "\\myserver\folder\"
    Set myOlApp = CreateObject("Outlook.Application")
    Set myItem = myOlApp.ActiveInspector
    If Not TypeName(myItem) = "Nothing" Then
        Set objItem = myItem.CurrentItem
        StrSub = objItem.Subject
        StrName = InputBox("Folder number...")
        Do While File_Exists(PathName & StrName & "\Emails\", True) = False
            StrName = InputBox("Folder does not exist, give a new number...", "new folder number")
        Loop
        Do While File_Exists(PathName & StrName & "\Emails\" & StrSub & ".msg") = True
            StrSub = InputBox("File exists, give a new file name...", "new file name", StrSub)
        Loop
        objItem.SaveAs PathName & StrName & "\Emails\" & StrSub & ".msg", olMSG
    Else
        MsgBox "There is no current opened email item."
    End If
End Sub

---

The following will work, and includes code to create the named folder, to remove illegal filename characters and create missing folders. Change the default path and domain name as appropriate.

Code:

---

Option Explicit

Sub SaveMessage()
'An Outlook macro by Graham Mayor - www.gmayor.com
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

Sub SaveItem(olItem As MailItem)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fname As String
Dim fPath As String
fPath = "\\myserver\folder\"
    fPath = InputBox("Enter the path to save the message." & vbCr & _
                    "The path will be created if it doesn't exist.", _
                    "Save Message", fPath)
    CreateFolders fPath

    If olItem.Sender Like "*@gmayor.com" Then    'Your domain
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    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, fPath, fname
lbl_Exit:
    Exit Sub
End Sub

Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function

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

---

[QUOTE=gmayor;340897]The following will work, and includes code to create the named folder, to remove illegal filename characters and create missing folders. Change the default path and domain name as appropriate.

Sorry, but I cannot get this to work, it doesn't seem to be finding the folder and I'm sure the path is correct in the code.

I note that the default path is a UNC network file path. In which case you are correct, the version of CreateFolders I posted would not work with such a path. (I wrote it down and still missed it :omg2:) Replace the CreateFolders and FolderExists functions with the following. Note the Root network drive must exist.

Code:

---

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

---

[QUOTE=gmayor;341051]I note that the default path is a UNC network file path. In which case you are correct, the version of CreateFolders I posted would not work with such a path. (I wrote it down and still missed it :omg2:) Replace the CreateFolders and FolderExists functions with the following. Note the Root network drive must exist.

Thanks heaps. I've messed about with this for some time, but I'm a real newie. I'm coming up with 'ambiguous name detected: Createfolders'

Sorry to be a pain, but would you mind pasting the complete code together? Clearly I'm just not nailing it on my end! :)

You appear to have added the second createfolders macro instead of replacing the original, hence the ambiguous name.

As long as the path you are saving to exists (here fPath = "\\myserver\folder\") , you can simplify the code to the following
Don't forget to put your own domain name in the line - If olItem.Sender Like "*@gmayor.com" Then 'Your domain:

Code:

---

Option Explicit
 
Sub SaveMessage()
    'An Outlook macro by Graham Mayor - www.gmayor.com
    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

Sub SaveItem(olItem As MailItem)
    'An Outlook macro by Graham Mayor - www.gmayor.com
    Dim fname As String
    Dim fPath As String
    fPath = "\\myserver\folder\" 'The path where the messages are to be saved
   
    If olItem.Sender Like "*@gmayor.com" Then 'Your domain
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
        Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
        Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    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, fPath, fname
lbl_Exit:
    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

---

That macro works great thanks very much. But rather than saving the messages to a root folder, we do want a popup so we can specify a folder within the default directory. Either create the folder if it's not there and save inside, or save it inside an already created folder. If the popup can just ask for a folder name (in our case a number like 78456) and create/save inside a folder of that name within our myserver\folder directory that would be awesome

That is what we had initially, once you change the CreateFolders macro for the second version? However if you are going to enter a number as the folder, then use the following, but before running it, change the network root folder to what you have there in the line below. The numbered folder will be created as a sub folder of that folder. Ensure that you retain the final backslash character.

Code:

---

Const fRootPath As String = "\\myserver\rootfoldername\"

---

By including the prompt for the folder you cannot conveniently use the main code as a script with a rule to automatically process the messages as they arrive.

Code:

---

Option Explicit
 
Sub SaveMessage()
    'An Outlook macro by Graham Mayor - www.gmayor.com
    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

Sub SaveItem(olItem As MailItem)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fname As String
Dim fPath As String
Const fRootPath As String = "\\myserver\rootfoldername\"
    fPath = InputBox("Enter the Folder Number in which to save the message." & vbCr & _
                    "The path will be created if it doesn't exist.", _
                    "Save Message")
    fPath = Replace(fPath, "\", "")
    fPath = fRootPath & fPath
    CreateFolders fPath

    If olItem.Sender Like "*@gmayor.com" Then    'Your domain
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    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, fPath, fname
lbl_Exit:
    Exit Sub
End Sub
 
Private 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

---

Hi GMayor,

I have been reading this post and found it very interesting as i'm trying to complete something very similar, but my folder structure is a bit different at the minute I have to find the folder location (\\server name\Projects\drawings\*customer*\*project number & name*) and then in the project name i have another folder *correspondence* and then two folders *sent* or *received*.

Would it be possible to change the code so that the text box appears twice so that i can put in the customer and the project name and number(example of project title: P1711 - Project Name), and then it saves the email in the correct folder either *sent* or *received* based on the email address and also creating a new folder with the date and time every time you save an email?

The following changes to the macro named below should work

Code:

---

Sub SaveItem(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 04/03/2017
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Const fRootPath As String = "\\server name\Projects\drawings\" 'Change the 'server name' as appropriate
    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")
    fPath2 = Replace(fPath2, "\", "")

    strPath = fRootPath & fPath1 & "\" & fPath2
    CreateFolders strPath
    CreateFolders strPath & "\Sent"
    CreateFolders strPath & "\Received"

    If olItem.sender Like "*@gmayor.com" Then    'Your domain
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "\Sent\" & fname
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "\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
lbl_Exit:
    Exit Sub
End Sub

---

Thanks Graham, that works exactly as it should. would it be possible to change it so that you dont have to put the full folder name in the second input box? i would like to only put project number X1234 its the same format for all folders 5 digital reference first.

also i have a folder within the main folder which is "correspondonce" would it be possible to created the "Sent" & "Received" folders in that folder?

Graham, I have managed to change the code to save in the correspondence folder, its just the 5 character input i need to change.

Code:

---

Option ExplicitSub 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
 
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\"
    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")
    fPath2 = Replace(fPath2, "\", "")
   
    strPath = fRootPath & fPath1 & "\" & fPath2
    CreateFolders strPath
    CreateFolders strPath & "Correspondence" & "\Sent"
    CreateFolders strPath & "Correspondence" & "\Received"
   
    If olItem.Sender Like "*@email.co.uk" 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
lbl_Exit:
    Exit Sub
End Sub
 
Private Sub CreateFolders(strPath As String)
    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)
    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
    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
Sub CopyToExcel(olItem As MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim enviro As String
    Dim strPath As String
   
    Dim objFolder As Outlook.MAPIFolder
    Dim strColA, strColB, strColC, strColD, strColE, strColF As String
   
    ' Get Excel set up
    enviro = CStr(Environ("USERPROFILE"))
    'the path of the workbook
    strPath = enviro & "\Documents\Book1.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error Resume Next
    ' Open the workbook to input the data
    ' Create workbook if doesn't exist
    Set xlWB = xlApp.Workbooks.Open(strPath)
    If Err <> 0 Then
        Set xlWB = xlApp.Workbooks.Add
        xlWB.SaveAs FileName:=strPath
    End If
    On Error GoTo 0
    Set xlSheet = xlWB.Sheets("Sheet1")
   
    On Error Resume Next
    ' add the headers if not present
    If xlSheet.Range("A2") = "" Then
        xlSheet.Range("A2") = "Sender Name"
        xlSheet.Range("B2") = "Sent To"
        xlSheet.Range("C2") = "Subject"
        xlSheet.Range("D2") = "Body"
        xlSheet.Range("E2") = "Date"
    End If
   
    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
    'needed for Exchange 2016. Remove if causing blank lines.
    rCount = rCount + 1
   
    'collect the fields
   
    strColA = olItem.SenderName
    strColB = olItem.To
    strColC = olItem.Subject
    strColD = olItem.Body
    strColE = olItem.ReceivedTime


           
    ' Get the Exchange address
    ' if not using Exchange, this block can be removed
    Dim olEU As Outlook.ExchangeUser
    Dim oEDL As Outlook.ExchangeDistributionList
    Dim recip As Outlook.Recipient
    Set recip = Application.Session.CreateRecipient(strColC)
   
   
    If InStr(1, strColB, "/") > 0 Then
        ' if exchange, get smtp address
        Select Case recip.AddressEntry.AddressEntryUserType
        Case OlAddressEntryUserType.olExchangeUserAddressEntry
            Set olEU = recip.AddressEntry.GetExchangeUser
            If Not (olEU Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olOutlookContactAddressEntry
            Set olEU = recip.AddressEntry.GetExchangeUser
            If Not (olEU Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
            Set oEDL = recip.AddressEntry.GetExchangeDistributionList
            If Not (oEDL Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        End Select
    End If
    ' End Exchange section
   
   
    'write them in the excel sheet
    xlSheet.Range("A" & rCount) = strColA
    xlSheet.Range("B" & rCount) = strColB
    xlSheet.Range("c" & rCount) = strColC
    xlSheet.Range("d" & rCount) = strColD
    xlSheet.Range("e" & rCount) = strColE
   
    'Next row
    rCount = rCount + 1
    xlWB.Save
          ' don't wrap lines
    xlSheet.Rows.WrapText = True
    xlWB.Save
    xlWB.Close 1
   
    If bXStarted Then
        'xlApp.Quit 'With looped messages it will be faster if Excel is not closed
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

---

Hi Graham,

I have been testing the code today and have noticed it is not saving my "SENT" emails in the correct folder it keeps saving them in the "RECEIVED" folder. I have tried changing

Code:

---

If olItem.Sender Like "*@email.co.uk" Then

---

to different emails or usernames but it still doesn't work. Any ideas as to why?


Also would it be possible to change this bit of code so that i only have to input 5 digits (X1234)

Code:

---

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")
    fPath2 = Replace(fPath2, "\", "")

---

Is 'email.co.uk' the demain name associated with your e-mail account? The line is checking for messages sent by you.
I don't understand the second part of your question. Can you clarify.

I have changed it to out domain in my copy, @dbensoncontrols.co.uk but that still doesn't seem to work.

Our folder structure is like this "\\Servername\Projects\Drawings\customer\P1234 Liverpool Street Station"

I would like to just search for the *P1234* in the folder not the full name - *P1234 liverpool street station* all projects start with the a letter followed by 4 digits.

Hope this helps

Did you include the asterisk?

Code:

---

*@dbensoncontrols.co.uk

---

The following function in the same module will give you the folder path (if it exists) from the five input characters
thus

Code:

---

fPath = GetPath

---

Code:

---

Private Function GetPath() As String
Const strRoot As String = "\\Servername\Private\Projects\Drawings\customer\"
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
    strPath = InputBox("Enter the 5 character 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

---

Yes, i have included the * still doesn't seem to work.

Could you please show me where to include the extra line.

Code:

---

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
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\"
   
    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")
    fPath2 = Replace(fPath2, "\", "")
   
    strPath = fRootPath & fPath1 & "\" & fPath2
    CreateFolders strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"
   
    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, i have fixed the issue with the sent folder, you have to put in your user name exactly and then it works.

If you would be able to help me with the Get Path Modification so i only have to put the customer name then the 5 characters that would be great!

Are you saying that in the line
Const strRoot As String = "\\Servername\Private\Projects\Drawings\customer\"
customer is the name of the customer?

Actually Private\ is from my network path and shouldn't be in the string, which explains why the function doesn't work :(.

Your last version shows the root as "\\NEWBENSON\Projects\drawings\" There is no reference to 'customer'

In your message you indicated Our folder structure is like this "\\Servername\Projects\Drawings\customer\P1234 Liverpool Street Station"
thus

\\NEWBENSON\Projects\drawings\customer name\P1234 Liverpool Street Station"
and that you want to add the folders
\\NEWBENSON\Projects\drawings\customer name\Correspondence\Sent"
and
\\NEWBENSON\Projects\drawings\customer name\Correspondence\Received"

In that case what's the relevance of the P1234? Is P1234 a unique ID that will identify the 'customer name' from minimal input? That is certainly possible with a modification to the GetPath.

Where is the workbook location relative to the path? Is it in the folder
\\NEWBENSON\Projects\drawings\customer name\
and it is that folder you now wish to locate or do you just want to identify the customer name (or both)?

Graham, we have an input box for the customer name already so that bit works fine. the project file "P1234 Liverpool Street Starion" is where I want to cut down the characters to look at just P1234 this is the unique I'd I want to use to find the folder.. This is fpath2 in the code

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.

Code:

---

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

---

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.

Code:

---

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

---

Graham,

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

thanks in advance.

Code:

---

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

---

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.

Code:

---

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

---

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!!

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

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.

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.

Code:

---

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

---

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.

Code:

---

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

---

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.

Code:

---

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

---

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 :(

Code:

---

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! 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

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

Code:

---

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.

Code:

---

CreateFolders strPath & "\Documents\Documents Received"

---

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

Code:

---

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

---

Graham! you my friend are a genius!!

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

REP ADDED!

Cheers
ND

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

Quote:

---

Originally Posted by Fredjo

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.

Done. Thanks Graham.

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.

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.

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 :(