Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 40

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

  1. #1
    VBAX Newbie
    Joined
    Apr 2016
    Posts
    4
    Location

    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?

    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

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

  3. #3
    VBAX Newbie
    Joined
    Apr 2016
    Posts
    4
    Location
    [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.

  4. #4
    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 ) Replace the CreateFolders and FolderExists functions with the following. Note the Root network drive must exist.

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

  5. #5
    VBAX Newbie
    Joined
    Apr 2016
    Posts
    4
    Location
    [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 ) 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!

  6. #6
    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:


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

  7. #7
    VBAX Newbie
    Joined
    Apr 2016
    Posts
    4
    Location
    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

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

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

  10. #10
    The following changes to the macro named below should work

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

  11. #11
    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?

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

    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

  13. #13
    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
    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)

    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, "\", "")

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

  15. #15
    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

  16. #16
    Did you include the asterisk?
    *@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
    fPath = GetPath
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

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

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

    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

    Last edited by nathandavies; 03-23-2017 at 08:03 AM. Reason: Inserted Code

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

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

  20. #20
    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

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
  •