code change to detect if Email has already been saved in location and show warning.

[nathandavies]

Hi all, i'm looking to make a code change the the code below and was wondering if someone would be able to help? i'm trying to write the code so that if an email and/or an attachment has already been saved in the location it will bring a pop-up box saving the email is already saved and does not save the email or attachment.

Option ExplicitPrivate Const strRoot As String = "\\NEWBENSON\Projects\Drawings\"
 
Public Sub Save()
      'Last updated - 18 Aug 2017
    Dim olObj As Object
    Dim olMsg As MailItem
    Dim selCount As Long
    Dim j As Long
    Dim fPath1 As String, fPath2 As String
    Dim strPath As String, strSavePath As String
     
    selCount = ActiveExplorer.Selection.Count
    If selCount = 0 Then GoTo lbl_Exit
     
    fPath1 = InputBox("Enter the customer folder name in which to save the messages." & 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 & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"
    CreateFolders strPath & "\Documents" & "\Documents Received"
        CreateFolders strPath & "\Documents" & "\Documents Sent"
     
    For j = selCount To 1 Step -1
        Set olObj = ActiveExplorer.Selection.Item(j)
        If olObj.Class = olMail Then
            Set olMsg = olObj


            SaveItem olItem:=olMsg, strPath:=strPath, bAttach:=True, bExcel:=False
        End If
    Next j
lbl_Exit:
    Exit Sub
End Sub
 
Private Function GetPath(strCustomer As String) As String
      'Last updated - 18 Aug 2017
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim bPath As Boolean
    Dim strPath As String
     
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
 
Private Sub SaveItem(olItem As MailItem, strPath As String, bAttach As Boolean, bExcel As Boolean)
      'Last updated - 18 Aug 2017
    Dim fname As String
    Dim strSavePath As String
     
    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
        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
     
     If olItem.Sender Like "Nathan Davies" Then 'INSERT NAME HERE
        If MsgBox("Save Attachments?", vbYesNo, "Save Attachments?") = vbYes Then
        SaveAttachments olItem, strPath & "\Documents\Documents Sent\"
        End If
     Else
        SaveAttachments olItem, strPath & "\Documents\Documents Received\"
    
    'If bExcel = True Then
    'CopyToExcel olItem, strPath
    
       End If
lbl_Exit:
    Exit Sub
End Sub


Private Sub SaveAttachments(olItem As MailItem, strSaveFolder As String)
    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
    strSaveFolder = strSaveFolder & Format(olItem.ReceivedTime, "yyyy-mm-dd") & Chr(92)
    CreateFolders strSaveFolder
    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
     
    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
 
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
     'Debug.Print strPath & strFileName & ".msg"
    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:
    Set FSO = Nothing
    Exit Function
End Function
 
Private Function FolderExists(fldr As String) As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If (FSO.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Set FSO = Nothing
    Exit Function
End Function

Thanks in advance
ND

[gmayor]

There is no simple way to do this. You will need to add a category to each message that you have processed and then check for that category before processing e.g.

    For j = selCount To 1 Step -1
        Set olObj = ActiveExplorer.Selection.Item(j)
        If olObj.Class = olMail Then
            If InStr(1, olObj.Categories, "Processed") = 0 Then 'Add this line
                Set olMsg = olObj
                SaveItem olItem:=olMsg, strPath:=strPath, bAttach:=True, bExcel:=False
                olObj.Categories = "Processed" 'add this line
                olObj.Save  'add this line
            End If
        End If
        DoEvents 'add this line
    Next j

[nathandavies]

Thanks for that its worked.