Hello,
I need to publish a productivity report which would be based on the count of emails sent by 10 - 15 employees from there Outlook on daily basis.
I have a vb code attached below which track down all emails details from local computer i.e. mine.
Now I want similar function where remotely via vb code I could pull out list of sent mails from diffrent outlook id.
Please help / suggest.
VB Code
Option Explicit
Dim RootFolder As String
Dim OlApp As Outlook.Application
Dim oMAPI As Outlook.Namespace
Dim oParentFolder As Outlook.MAPIFolder
Dim ws As Worksheet
Dim intTotalItems As Long
Dim intRowPointer As Long
Public Sub GetOutlookMail()
Dim dteTimer As Date
RootFolder = "Mailbox - Kaushik Dey"
dteTimer = Now()
Set ws = ThisWorkbook.Sheets("List")
Set OlApp = CreateObject("Outlook.Application")
Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
Set oParentFolder = oMAPI.Folders(RootFolder)
intTotalItems = 0
Call CountAllItems(oParentFolder)
ws.Columns("A:S").ClearContents
Call ColumnHeaders
intRowPointer = 2
Application.Cursor = xlWait
Call ProcessFolder(oParentFolder)
Application.Cursor = xlDefault
MsgBox "Emails Downloaded"
Data
Set OlApp = Nothing
End Sub
Private Sub CountAllItems(StartFolder As Outlook.MAPIFolder)
Dim uFolder As Outlook.MAPIFolder
Dim MailObject As Object
If StartFolder.DefaultItemType = 0 And StartFolder.FolderPath <> "" & RootFolder Then
intTotalItems = intTotalItems + StartFolder.Items.Count
End If
If StartFolder.DefaultItemType = 0 Then
For Each uFolder In StartFolder.Folders
Call CountAllItems(uFolder)
Next uFolder
End If
Set uFolder = Nothing
End Sub
Private Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
Dim uFolder As Outlook.MAPIFolder
If StartFolder.DefaultItemType = 0 Then
Call ProcessItems(StartFolder, StartFolder.Items)
For Each uFolder In StartFolder.Folders
Call ProcessFolder(uFolder)
Next uFolder
End If
Set uFolder = Nothing
End Sub
Private Sub ProcessItems(CurrentFolder As Outlook.MAPIFolder, Collection As Outlook.Items)
Dim MailObject As Object
Dim intAttachment As Integer
For Each MailObject In Collection
DoEvents
If TypeOf MailObject Is MailItem Then
ws.Cells(intRowPointer, 1) = MailObject.SentOn
ws.Cells(intRowPointer, 2) = MailObject.SenderName
ws.Cells(intRowPointer, 3) = MailObject.SenderEmailAddress
ws.Cells(intRowPointer, 4) = MailObject.SentOnBehalfOfName
ws.Cells(intRowPointer, 5) = MailObject.To
ws.Cells(intRowPointer, 6) = MailObject.CC
ws.Cells(intRowPointer, 7) = MailObject.BCC
ws.Cells(intRowPointer, 8) = MailObject.ReceivedByName
ws.Cells(intRowPointer, 9) = MailObject.ReceivedOnBehalfOfName
ws.Cells(intRowPointer, 10) = MailObject.ReplyRecipientNames
ws.Cells(intRowPointer, 11) = MailObject.Subject
ws.Cells(intRowPointer, 12) = MailObject.Body
ws.Cells(intRowPointer, 13) = MailObject.HTMLBody
ws.Cells(intRowPointer, 14) = MailObject.Importance
ws.Cells(intRowPointer, 15) = MailObject.Attachments.Count
ws.Cells(intRowPointer, 16) = ""
For intAttachment = 1 To MailObject.Attachments.Count
'ws.Cells(intRowPointer, 16) = ws.Cells(intRowPointer, 16) & ";" & MailObject.Attachments(intAttachment).Filename
' we may want to save some or all of the attachments
' MailObject.Attachments(intAttachment).SaveAsFile "C:Temp" & MailObject.Attachments(intAttachment).FileName
Next intAttachment
ws.Cells(intRowPointer, 16) = Mid(ws.Cells(intRowPointer, 16), 2) ' remove leading semicolon
ws.Cells(intRowPointer, 17) = CurrentFolder.FolderPath
ws.Cells(intRowPointer, 18) = CurrentFolder.Name
If MailObject.UnRead Then
ws.Cells(intRowPointer, 19) = "N"
Else
ws.Cells(intRowPointer, 19) = "Y"
End If
intRowPointer = intRowPointer + 1
End If
Next MailObject
Set MailObject = Nothing
End Sub
Private Sub ColumnHeaders()
Dim ColumnHeads As Variant
ColumnHeads = Array("SenderName", "SenderEmailAddress", "SentOnBehalfOfName", "To", "CC", _
"BCC", "ReceivedByName", "ReceivedOnBehalfOfName", "ReplyRecipientNames", "Subject", _
"SentOn", "Body", "HTMLBody", "Importance", "AttachmentsCount", "Attachments", _
"FolderPath", "FolderName", "Read")
ws.Range("A1").Resize(1, UBound(ColumnHeads) + 1) = ColumnHeads
Rows("2").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
ws.Rows("1").Font.Bold = True
End Sub
Sub Data()
Sheets("list").Select
Range("A1").Select
Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 19)).Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
I need to publish a productivity report which would be based on the count of emails sent by 10 - 15 employees from there Outlook on daily basis.
I have a vb code attached below which track down all emails details from local computer i.e. mine.
Now I want similar function where remotely via vb code I could pull out list of sent mails from diffrent outlook id.
Please help / suggest.
VB Code
Option Explicit
Dim RootFolder As String
Dim OlApp As Outlook.Application
Dim oMAPI As Outlook.Namespace
Dim oParentFolder As Outlook.MAPIFolder
Dim ws As Worksheet
Dim intTotalItems As Long
Dim intRowPointer As Long
Public Sub GetOutlookMail()
Dim dteTimer As Date
RootFolder = "Mailbox - Kaushik Dey"
dteTimer = Now()
Set ws = ThisWorkbook.Sheets("List")
Set OlApp = CreateObject("Outlook.Application")
Set oMAPI = GetObject("", "Outlook.application").GetNamespace("MAPI")
Set oParentFolder = oMAPI.Folders(RootFolder)
intTotalItems = 0
Call CountAllItems(oParentFolder)
ws.Columns("A:S").ClearContents
Call ColumnHeaders
intRowPointer = 2
Application.Cursor = xlWait
Call ProcessFolder(oParentFolder)
Application.Cursor = xlDefault
MsgBox "Emails Downloaded"
Data
Set OlApp = Nothing
End Sub
Private Sub CountAllItems(StartFolder As Outlook.MAPIFolder)
Dim uFolder As Outlook.MAPIFolder
Dim MailObject As Object
If StartFolder.DefaultItemType = 0 And StartFolder.FolderPath <> "" & RootFolder Then
intTotalItems = intTotalItems + StartFolder.Items.Count
End If
If StartFolder.DefaultItemType = 0 Then
For Each uFolder In StartFolder.Folders
Call CountAllItems(uFolder)
Next uFolder
End If
Set uFolder = Nothing
End Sub
Private Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
Dim uFolder As Outlook.MAPIFolder
If StartFolder.DefaultItemType = 0 Then
Call ProcessItems(StartFolder, StartFolder.Items)
For Each uFolder In StartFolder.Folders
Call ProcessFolder(uFolder)
Next uFolder
End If
Set uFolder = Nothing
End Sub
Private Sub ProcessItems(CurrentFolder As Outlook.MAPIFolder, Collection As Outlook.Items)
Dim MailObject As Object
Dim intAttachment As Integer
For Each MailObject In Collection
DoEvents
If TypeOf MailObject Is MailItem Then
ws.Cells(intRowPointer, 1) = MailObject.SentOn
ws.Cells(intRowPointer, 2) = MailObject.SenderName
ws.Cells(intRowPointer, 3) = MailObject.SenderEmailAddress
ws.Cells(intRowPointer, 4) = MailObject.SentOnBehalfOfName
ws.Cells(intRowPointer, 5) = MailObject.To
ws.Cells(intRowPointer, 6) = MailObject.CC
ws.Cells(intRowPointer, 7) = MailObject.BCC
ws.Cells(intRowPointer, 8) = MailObject.ReceivedByName
ws.Cells(intRowPointer, 9) = MailObject.ReceivedOnBehalfOfName
ws.Cells(intRowPointer, 10) = MailObject.ReplyRecipientNames
ws.Cells(intRowPointer, 11) = MailObject.Subject
ws.Cells(intRowPointer, 12) = MailObject.Body
ws.Cells(intRowPointer, 13) = MailObject.HTMLBody
ws.Cells(intRowPointer, 14) = MailObject.Importance
ws.Cells(intRowPointer, 15) = MailObject.Attachments.Count
ws.Cells(intRowPointer, 16) = ""
For intAttachment = 1 To MailObject.Attachments.Count
'ws.Cells(intRowPointer, 16) = ws.Cells(intRowPointer, 16) & ";" & MailObject.Attachments(intAttachment).Filename
' we may want to save some or all of the attachments
' MailObject.Attachments(intAttachment).SaveAsFile "C:Temp" & MailObject.Attachments(intAttachment).FileName
Next intAttachment
ws.Cells(intRowPointer, 16) = Mid(ws.Cells(intRowPointer, 16), 2) ' remove leading semicolon
ws.Cells(intRowPointer, 17) = CurrentFolder.FolderPath
ws.Cells(intRowPointer, 18) = CurrentFolder.Name
If MailObject.UnRead Then
ws.Cells(intRowPointer, 19) = "N"
Else
ws.Cells(intRowPointer, 19) = "Y"
End If
intRowPointer = intRowPointer + 1
End If
Next MailObject
Set MailObject = Nothing
End Sub
Private Sub ColumnHeaders()
Dim ColumnHeads As Variant
ColumnHeads = Array("SenderName", "SenderEmailAddress", "SentOnBehalfOfName", "To", "CC", _
"BCC", "ReceivedByName", "ReceivedOnBehalfOfName", "ReplyRecipientNames", "Subject", _
"SentOn", "Body", "HTMLBody", "Importance", "AttachmentsCount", "Attachments", _
"FolderPath", "FolderName", "Read")
ws.Range("A1").Resize(1, UBound(ColumnHeads) + 1) = ColumnHeads
Rows("2").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
ws.Rows("1").Font.Bold = True
End Sub
Sub Data()
Sheets("list").Select
Range("A1").Select
Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 19)).Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
