The following code does everything I want: pulls email, saves attachments, extracts files EXCEPT save the original email to the folder fDest. I seem unable to see the solution.
This seems to be the problematic line as it won't save the email: "mi.SaveAs fDest2, olMSG"
Sub SaveAttachments()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.Attachment
Dim Inbox As MAPIFolder
Dim strDate As String
Dim oApp As Object
Dim fDest As Variant
Dim j As Variant
Dim sh As String
Dim FileDialog As FileDialog
Dim Tracker As Workbook
Dim fSheet As Sheets
Dim LastRow As Long
Dim strFilePath
Dim fTracker As Workbook
strDate = InputBox("Enter Date in format dd-Mmm-yyyy", "User Date", Format(Now(), "dd-Mmm-yyyy"))
strFilePath = "\\namdfs\CARDS\MWD\GROUPS\GCM_NAM\2021\05 May\"
fTrackerName = "Inquiry.Tracker.SWPA.Violations.May.2021.xlsx" '
On Error Resume Next
Set fTracker = Workbooks(fTrackerName)
'If Err Then Set fTracker = Workbooks.Open(strFilePath & fTrackerName)
On Error GoTo 0
'Windows(fTrackerName).Activate
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.Folders("GCMNamLogs").Folders("Inbox")
fDest = "C:\Users\jb76991\Desktop\Violations_Emails\"
fUser = UCase(Environ("username")) & ":" & Chr(10) & Now()
For Each i In fol.Items.Restrict("@SQL=urn:schemas:httpmail:subject LIKE '%" & strDate & "%'")
'Debug.Print fDest & i & ".msg"
If i.Class = olMail Then
Set mi = i
fDest2 = fDest & mi.Subject & ".msg"
mi.SaveAs fDest2, olMSG
For Each at In mi.Attachments
'do something with attachments but i've commented it out
Next at
End If
Next i
MsgBox ("Completed")
End Sub
Can anyone tell me how to save the original emails that are being filtered?
