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

[nathandavies]

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