I take emails a user selects and then save them as text files, with the name of the text file as a portion of the subject line and then move that email to another folder in Outlook.
I managed to get all that working, but I also want the code to leave anything with two trip numbers in the subject line (Signified as Trip#XXXXXXXXX) alone and not move it, instead moving to the next selected email.
Exit Sub is a hard stop and I want to loop through the rest of the selection. Next oMail is something I'm only allowed one of and need at the end and GoTo that location skipping the rest of the code doesn't help.
Should I be using something other than For Each oMail In Application.ActiveExplorer.Selection?
The whole thing is as follows:
Sub SaveSentEmailAsParsedSubjectAndMove()
Dim oMail As Outlook.MailItem
'Folder path and file name
Dim strDesktop As String, strFileName As String, strFolderPath As String
'Four letters at the start of a trip/PAPS/PARS and the number itself
Dim strSCAC As String, strTripNumber As String
'Trip number counter
Dim strSubject As String, strSubject2 As String
Dim intTrips As Integer, intTrips1 As Integer, intTrips2 As Integer
'Duplicate checker
'Dim strTestStr As String, strTestPath As String
Dim strVersion As String, strVersionCheck As String
'File saved counter
Dim intFilesSaved As Integer
intFilesSaved = 0
'X carries the value for the file name, trying to save one higher in the event of a duplicate
Dim x As Integer
'Creates a text file on the desktop that will have all saved trip numbers written into it for the day.
Dim objFSO As Object
'Dim objFSO As New FileSystemObject
Dim objDailyLog As Object
'Dim objDailyLog As TextStream
Dim strTextFilePath As String
Dim strTextFilePathTest As String
'Constants for reading/writing to the daily log file - Appending adds data to the end.
'For Reading = 1
'For Writing = 2
'For Appending = 8
'Variables for the timers
'Daily log save time timer
Dim sngStart As Single, sngEnd As Single, sngElapsed As Single
Dim sngStart2 As Single, sngEnd2 As Single, sngElapsed2 As Single
If ActiveExplorer.Selection.Count = 0 Then
MsgBox "No files selected"
Exit Sub
End If
'Start timer
sngStart = Timer
sngStart2 = Timer
1
x = 1
'Set folder path - This will have to change to the J daily fax for release - J:\Fax Confirmations Daily
strDesktop = Environ("userprofile")
strFolderPath = strDesktop & "\Desktop\Test Folder\"
If Len(Dir(strFolderPath)) = 0 Then
MkDir strFolderPath
Else
End If
'strFolderPath = "J:\Fax Confirmations Daily\"
'Sets the path to create the record keeping text file in.
strTextFilePath = strDesktop & "\Desktop\" & Month(Date) & " " & Day(Date) & " Saved Faxes.txt"
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Len(Dir(strTextFilePath)) = 0 Then
'MsgBox "File does NOT exist"
Set objDailyLog = objFSO.CreateTextFile(strTextFilePath)
objDailyLog.Close
Else
'MsgBox "File already exists"
End If
'This will save all emails selected
For Each oMail In Application.ActiveExplorer.Selection
'Gets the subject line of the mail item
strSubject = oMail.Subject
'Gets the SCAC code from the subject line, the first four characters counting from left
strSCAC = strSubject
strSCAC = Left(strSCAC, 4)
'Counter. Stops process and returns error if there is more than one trip number detected.
strSubject2 = oMail.Subject
strSubject2 = Replace(strSubject2, "#", "")
intTrips1 = Len(strSubject)
intTrips2 = Len(strSubject2)
intTrips = intTrips1 - intTrips2
If intTrips > 1 Then
MsgBox "You have selected an email with more than one trip number in the subject. Please only select messages with a single trip number. Thanks.", 0, "Multiple Trip Numbers Detected"
GoTo 3
'Exit Sub
Else
'Gets the trip number, hereby defined as everything to the RIGHT of the # in the subject line
strTripNumber = strSubject
strTripNumber = Mid(strSubject, InStr(strSubject, "#") + 1)
'Set the File name
strVersion = ""
strFileName = strSCAC & strTripNumber & strVersion
2
'Test if file name exists. If yes, increase version number by 1 and try again.
'If no, save and continue processing.
If Len(Dir(strFolderPath & strFileName & " Sent" & strVersion & ".txt")) = 0 Then
'Save the text file with the completed file name to the previously defined folder
oMail.SaveAs strFolderPath & strFileName & " Sent" & strVersion & ".txt", olTXT
intFilesSaved = intFilesSaved + 1
'Open daily log file for addending (do not overwrite current data, merely add new lines to bottom)
Set objDailyLog = objFSO.OpenTextFile(strTextFilePath, 8, True)
objDailyLog.WriteLine (strFileName & " " & strVersion)
'Close the daily log text file
objDailyLog.Close
Else
'If the file already exists, increase the version counter by 1 and try again.
x = x + 1
strVersion = " " & x
GoTo 2
End If
End If
x = 1
'MoveToBackup
3
Next oMail
If intTrips > 1 Then
Set objDailyLog = objFSO.OpenTextFile(strTextFilePath, 8, True)
objDailyLog.WriteLine (Time)
objDailyLog.WriteLine "Saved in " & sngElapsed & " seconds"
objDailyLog.WriteLine "Error detected: Multiple trip numbers in subject line!"
objDailyLog.WriteBlankLines (1)
objDailyLog.Close
sngEnd2 = Timer
sngElapsed2 = Format(sngEnd2 - sngStart2, "Fixed")
MsgBox intFilesSaved & " file(s) saved successfully" & " in " & sngElapsed2 & " seconds", 0, "Files Saved"
intTrips = 0
Else
MoveToBackup
sngEnd = Timer
sngElapsed = Format(sngEnd - sngStart, "Fixed")
Set objDailyLog = objFSO.OpenTextFile(strTextFilePath, 8, True)
objDailyLog.WriteLine (Time)
objDailyLog.WriteLine "Saved in " & sngElapsed & " seconds"
objDailyLog.WriteBlankLines (1)
objDailyLog.Close
sngEnd2 = Timer
sngElapsed2 = Format(sngEnd2 - sngStart2, "Fixed")
MsgBox intFilesSaved & " file(s) saved successfully" & " in " & sngElapsed2 & " seconds", 0, "Files Saved"
End If
End Sub
'Outlook VB Macro to move selected mail item(s) to a target folder
Sub MoveToBackup()
On Error Resume Next
Dim ns As Outlook.NameSpace
Dim moveToFolder As Outlook.MAPIFolder
Dim objItem As Outlook.MailItem
Set ns = Application.GetNamespace("MAPI")
'Define path to the target folder - this was the original code,
Set moveToFolder = ns.GetDefaultFolder(olFolderSentMail).Folders("Backup")
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox ("No item selected")
Exit Sub
End If
If moveToFolder Is Nothing Then
MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
End If
For Each objItem In Application.ActiveExplorer.Selection
If moveToFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move moveToFolder
End If
End If
Next
Set objItem = Nothing
Set moveToFolder = Nothing
Set ns = Nothing
End Sub
You are already dropping items from the selection with
If intTrips > 1 Then
but later you move all mail in the selection.
You could move validated mail immediately.
Sub MoveValidatedMail()
Dim oMail As mailItem
'Four letters at the start of a trip/PAPS/PARS and the number itself
Dim strSCAC As String, strTripNumber As String
'Trip number counter
Dim strSubject As String, strSubject2 As String
Dim intTrips As Integer, intTrips1 As Integer, intTrips2 As Integer
'Move vaidated mail one at a time,
' within this code, rather than bulk move all mail
Dim ns As namespace
Dim moveToFolder As Folder
Dim objItem As Object
Set ns = GetNamespace("MAPI")
'Define path to the target folder
' If there is a typo or missing folder there would be an error.
' Bypass this one error only.
On Error Resume Next
Set moveToFolder = ns.GetDefaultFolder(olFolderSentMail).folders("Backup")
On Error GoTo 0
If moveToFolder Is Nothing Then
' Handle the bypassed error, if any
MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
Exit Sub
End If
If moveToFolder.DefaultItemType <> olMailItem Then
MsgBox "DefaultItemType <> olMailItem!", vbOKOnly + vbExclamation, "Move Macro Error"
Exit Sub
End If
If ActiveExplorer.Selection.count = 0 Then
MsgBox "No files selected"
Exit Sub
End If
For Each objItem In ActiveExplorer.Selection
If objItem.Class = olMail Then
Set oMail = objItem
'Gets the subject line of the mail item
strSubject = oMail.subject
'Gets the SCAC code from the subject line,
' the first four characters counting from left
strSCAC = strSubject
strSCAC = Left(strSCAC, 4)
'Counter. Stops process and returns error
' if there is more than one trip number detected.
strSubject2 = oMail.subject
strSubject2 = Replace(strSubject2, "#", "")
intTrips1 = Len(strSubject)
intTrips2 = Len(strSubject2)
intTrips = intTrips1 - intTrips2
If intTrips > 1 Then
MsgBox "Mail not moved " & oMail.subject
Else
' Move validated mail
objItem.move moveToFolder
MsgBox oMail.subject & " moved to " & moveToFolder
End If
End If
Set oMail = Nothing
Next objItem
Set oMail = Nothing
Set objItem = Nothing
Set moveToFolder = Nothing
Set ns = Nothing
End Sub