Sub GetMailInfo()
Dim results() As String
' get contacts
results = ExportEmails(True)
' paste onto worksheet
Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results
MsgBox "Completed"
End Sub
Function ExportEmails(Optional headerRow As Boolean = False) As String()
Dim objOutlook As Object 'Outlook.Application
Dim objNamespace As Object 'Outlook.Namespace
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object 'Outlook.Items
Dim folderItem As Object
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for Attachments
Dim debugMsg As Integer
'arnelgp
Dim Country, Department, Lines, Typ, Itm1, Itm2
Dim strAttach As String, strPath As String
Dim objAttach As Object
strPath = Environ$("temp") & "\"
' select output results worksheet and clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook results").Cells.ClearContents
Range("A1").Select
Set objOutlook = CreateObject("Outlook.Application")
'MsgBox objOutlook, vbOKOnly 'for debugging
Set objNamespace = objOutlook.GetNamespace("MAPI")
'MsgBox objNamespace, vbOKOnly 'for debugging
'Set objInbox = objNamespace.GetDefaultFolder (olFolderInbox)
'MsgBox objInbox, vbOKOnly 'for debugging
Set strFolderName = objNamespace.PickFolder
Set mailFolderItems = strFolderName.Items
' if calling procedure wants header row
If headerRow Then
startRow = 1
Else
startRow = 0
End If
numRows = mailFolderItems.Count
' resize array
ReDim tempString(1 To (numRows + startRow), 1 To 100)
' loop through folder items
For i = 1 To numRows
Set folderItem = mailFolderItems.Item(i)
If IsMail(folderItem) Then
Set msg = folderItem
End If
With msg
tempString(i + startRow, 1) = .ReceivedByName
tempString(i + startRow, 2) = .ReceivedTime
tempString(i + startRow, 3) = .SenderEmailAddress
tempString(i + startRow, 4) = .SenderName
tempString(i + startRow, 5) = .SentOn
tempString(i + startRow, 6) = .Size
tempString(i + startRow, 7) = .Subject
tempString(i + startRow, 8) = .To
End With
' adding file attachment names where they exist - added by JP
If msg.Attachments.Count > 0 Then
For jAttach = 1 To msg.Attachments.Count
Set objAttach = msg.Attachments.Item(jAttach)
strAttach = msg.Attachments.Item(jAttach).DisplayName
tempString(i + startRow, 39 + jAttach) = strAttach
'arnelgp
If Right$(strAttach, 4) = ".xls" Or _
Right$(strAttach, 5) Like ".xls*" Then
Country = "": Department = "": Lines = 0
Typ = "": Itm1 = "": Itm2 = ""
On Error Resume Next
Kill strPath & strAttach
objAttach.SaveAsFile strPath & strAttach
Call ProcessWB(strPath & strAttach, Country, Department, Lines, Typ, Itm1, Itm2)
Set objAttach = Nothing
tempString(i + startRow, 9) = Country
tempString(i + startRow, 10) = Department
tempString(i + startRow, 11) = Lines
tempString(i + startRow, 12) = Typ
tempString(i + startRow, 13) = Itm1
tempString(i + startRow, 14) = Itm2
End If
Next jAttach
End If
Next i
' first row of array should be header Values
If headerRow Then
tempString(1, 1) = "ReceivedByName"
tempString(1, 2) = "ReceivedTime"
tempString(1, 3) = "SenderEmailAddress"
tempString(1, 4) = "SenderName"
tempString(1, 5) = "SentOn"
tempString(1, 6) = "size"
tempString(1, 7) = "subject"
tempString(1, 8) = "To"
'arnelgp
tempString(1, 9) = "Country"
tempString(1, 10) = "Department"
tempString(1, 11) = "No. of line items count"
tempString(1, 12) = "Type"
tempString(1, 13) = "Item1"
tempString(1, 14) = "Item2"
End If
ExportEmails = tempString
' apply pane freeze and filtering
Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
'Selection.AutoFilter
End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
'arnelgp
Public Function ProcessWB(ByVal wbName As String, _
ByRef Country, _
ByRef Dept, _
ByRef Lines, _
ByRef Typ, _
ByRef Itm1, _
ByRef Itm2) As Boolean
Static objExcel As Excel.Application
Dim wb As Workbook, sh As Worksheet
If objExcel Is Nothing Then
Set objExcel = New Excel.Application
End If
Set wb = objExcel.Workbooks.Open(wbName)
Set sh = wb.Sheets(1)
With sh
Country = .Range("A2") & ""
Dept = .Range("B2") & ""
Typ = .Range("D2") & ""
Itm1 = .Range("K2") & ""
Itm2 = .Range("L2") & ""
Lines = .Cells(.Rows.Count, 1).End(xlUp).Row - 3
End With
Set sh = Nothing
wb.Close False
Set wb = Nothing
End Function