Hi All,
I've created a code to fetch email summary from Outlook to excel. It successfully runs on my system.
This automation is for a shared mailbox, and it was running successfully on the shared mailbox last month with the same file for users, but now for that shared mailbox it's throwing blank result in spite of data being there, or at times there's an error stating invalid date.
Whereas the same automation is running for my mailbox (Not a shared one)
Has it to do something with shared mailbox?
But than the same file was giving results till May.
Can someone help me out why's the macro behaving this way!
Code
Public StartTime As Double
Public MinutesElapsed As String
Public Sub ReadOutlookEmails()
Application.ScreenUpdating = False
StartTime = Timer
Sheet2.Rows("2:1048576").ClearContents
If Worksheets("Run").Range("G3").Value <> "" Then
Dim mail_date As Date
date_filter = "Yes"
On Error GoTo ErrorMessage1
mail_date = Worksheets("Run").Range("G3").Value
Else
date_filter = "No"
End If
Sheet2.Range("A1").Value = "Sender"
Sheet2.Range("B1").Value = "To"
Sheet2.Range("C1").Value = "Cc"
Sheet2.Range("D1").Value = "Subject"
Sheet2.Range("E1").Value = "Received Date"
Sheet2.Range("F1").Value = "Received Time"
Sheet2.Range("G1").Value = "Body"
Sheet2.Range("H1").Value = "Category"
Sheet2.Range("I1").Value = "Flag Request"
Sheet2.Range("J1").Value = "Importance"
Sheet2.Range("K1").Value = "Read/Unread"
Sheet2.Range("L1").Value = "Attachement Count"
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Outlook.MailItem
Dim RowCount1, Email_Count As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.PickFolder 'Pick Outlook folder
Set OutlookMail = ActiveExplorer.Selection.Item(1)
RowCount1 = 1
For Each OutlookMail In Folder.Items
DoEvents
On Error Resume Next
If date_filter = "Yes" Then
If FormatDateTime(OutlookMail.ReceivedTime, 2) < FormatDateTime(mail_date, 2) Then Exit For 'Check email received time as per the selected date
End If
'If FormatDateTime(OutlookMail.ReceivedTime, 2) = FormatDateTime(mail_date, 2) Then
Sheet2.Range("A1").Offset(RowCount1, 0).Value = OutlookMail.SenderName
Sheet2.Range("B1").Offset(RowCount1, 0).Value = OutlookMail.To
Sheet2.Range("C1").Offset(RowCount1, 0).Value = OutlookMail.CC
Sheet2.Range("D1").Offset(RowCount1, 0).Value = OutlookMail.Subject
Sheet2.Range("E1").Offset(RowCount1, 0).Value = OutlookMail.ReceivedTime
Sheet2.Range("F1").Offset(RowCount1, 0).Value = FormatDateTime(OutlookMail.ReceivedTime, 3)
Sheet2.Range("G1").Offset(RowCount1, 0).Value = OutlookMail.Body
Sheet2.Range("H1").Offset(RowCount1, 0).Value = OutlookMail.Categories
Sheet2.Range("I1").Offset(RowCount1, 0).Value = OutlookMail.FlagRequest
Sheet2.Range("J1").Offset(RowCount1, 0).Value = OutlookMail.Importance
If OutlookMail.UnRead = True Then
Sheet2.Range("K1").Offset(RowCount1, 0).Value = "Unread"
Else
Sheet2.Range("K1").Offset(RowCount1, 0).Value = "Read"
End If
Sheet2.Range("L1").Offset(RowCount1, 0).Value = OutlookMail.Attachments.Count
RowCount1 = RowCount1 + 1
'End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
Email_Count = Application.WorksheetFunction.CountA(Application.Sheet2.Range("A:A"))
Save_Data
Exit Sub
ErrorMessage1:
MsgBox "Please enter a valid date"
End Sub
Sub Save_Data()
'Sheet2.Visible = xlSheetVisible
Sheet2.Select
lr = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
'If lr > 1 Then
'Sheet2.Range("N2:N" & lr).FormulaR1C1 = "=DATE(YEAR(RC[-9]),MONTH(RC[-9]),DAY(RC[-9]))"
'Sheet2.Range("E2:E" & lr).Value = Sheet2.Range("N2:N" & lr).Value
'Sheet2.Range("N2:N" & lr).ClearContents
'End If
Range("E2:E" & lr).NumberFormat = "dd-mmm-yy"
Range("A1").Select
Sheet1.Select
Sheets("Email_Data").Copy
Dim FoldPath As String
Dim DialogBox As FileDialog
Dim FileOpen As String
On Error Resume Next
Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker)
If DialogBox.Show = -1 Then
FoldPath = DialogBox.SelectedItems(1)
End If
Range("A1").Select
file_name = "Email_Summary_" & Format(Now, "DD-MM-YY HH-MM")
ActiveWorkbook.SaveAs Filename:=FoldPath & "\" & file_name
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Your data has been saved at the below path" & vbNewLine & FoldPath & vbNewLine & _
"This MIS ran successfully in " & MinutesElapsed & " minutes", vbInformation
End Sub