Option Explicit
Sub SaveEmailDetails()
Dim olkMsg As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
intRow As Integer, _
intVersion As Integer, _
strFilename As String, _
TextBody As String, _
Index As Integer, _
tmpIndex As Integer, _
strSent As String, _
subStrSent As String
strFilename = "C:\phani\RespondedMails\" & Format(Now(), "yymmdd hhmmss") & ".xls"
If strFilename <> "" Then
' intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add
Set excWks = excWkb.ActiveSheet
'Write Excel Column Headers
With excWkb
.Worksheets("Sheet1").Name = "Data"
With .Worksheets("Data")
With .Cells(1, 1)
.Value = "Subject"
.Font.Bold = True
End With
With .Cells(1, 2)
.Value = "Replied at"
.Font.Bold = True
End With
With .Cells(1, 3)
.Value = "Received at"
.Font.Bold = True
End With
With .Cells(1, 4)
.Value = "Sender"
.Font.Bold = True
End With
With .Cells(1, 5)
.Value = "Response Time"
.Font.Bold = True
End With
.Columns("A").ColumnWidth = 100
.Columns("B").ColumnWidth = 15
.Columns("C").ColumnWidth = 15
.Columns("D").ColumnWidth = 15
.Columns("E").ColumnWidth = 15
End With
End With
intRow = 2
'Write messages to spreadsheet
For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
'********* Mail received time *******
TextBody = olkMsg.Body
Index = InStr(1, TextBody, "Sent:", vbTextCompare)
tmpIndex = InStr(Index, TextBody, ",", vbTextCompare)
strSent = Right(TextBody, Len(TextBody) - tmpIndex - 1)
subStrSent = Left(strSent, InStr(1, strSent, "To:", vbTextCompare) - 3)
'********* End Mail received time *******
excWks.Cells(intRow, 3) = subStrSent
excWks.Cells(intRow, 4) = GetSMTPAddress(olkMsg, intVersion)
excWks.Cells(intRow, 5) = CalcDiff2Dates(olkMsg.ReceivedTime, subStrSent)
intRow = intRow + 1
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
End If
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Process complete. A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
'Dim olkPrp As Object
On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTP2007(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
'Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function
<name removed="">
Function CalcDiff2Dates(ByVal d1 As Date, _
ByVal d2 As Date) As String
Dim Second As Long, Day As Long, Hour As Long
Dim CompleteHour As String
Second = DateDiff("s", d1, d2)
Hour = Second \ 3600
If Hour > 23 Then
Day = Hour \ 24
CompleteHour = Format((d2 - d1), "hh:mm:ss")
Else
Day = 0
CompleteHour = Format((d2 - d1), "hh:mm:ss")
End If
If Day = 0 Then
CalcDiff2Dates = CompleteHour
Else
CalcDiff2Dates = Day & " day(s), " & CompleteHour
End If
Exit Function
End Function
