spittingfire
10-18-2017, 02:14 PM
Hi All,
Looking for some help with an Outlook vb code.
I have the below code that I've put together but not getting the expected results.
I get a few emails a day with the a standard subject line Stats @ 9:00 18/10/2017, Stats @11:00 18/10/2017, Stats @ 13:00 18/10/2017, Stats @ 15:00 18/10/2017, Stats @ 17:00 18/10/2017, Stats @ 19:00 18/10/2017 and Stats @ 21:00 18/10/2017.
I'm trying to export each to a specific column in an excel file that I have created.
The vb code that I have is
Sub ExportMessagesToExcel()
Dim olkMsg As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
rCount As Long, _
intVersion As Integer
Dim subFolderName As String
MailboxName = "***@r***.com"
Pst_Folder_Name = "Inbox"
subFolderName = "stats"
Set Folder = Outlook.Session.Folders("***@***.com").Folders("Inbox").Folders("stats")
Const strPath As String = "B:\NCC\stats.xlsm" 'the path of the workbook
On Error Resume Next
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Open(strPath)
Set excWks = excWkb.Worksheets("Sheet1")
excWks.Range("A1:I1000").ClearContents
'Write Excel Column Headers
rCount = excWks.Range("D" & excWks.Rows.Count).End(-4162).Row
intRow = excWks.Range("A" & excWks.Rows.Count).End(-4162).Row
With excWks
excWks.Range("A" & 1).Value = "Stats @ 09:00"
excWks.Range("B" & 1).Value = "Stats @ 11:00"
excWks.Range("C" & 1).Value = "Stats @ 13:00"
excWks.Range("D" & 1).Value = "Stats @ 15:00"
excWks.Range("E" & 1).Value = "Stats @ 17:00"
excWks.Range("F" & 1).Value = "Stats @ 19:00"
excWks.Range("G" & 1).Value = "Stats @ 21:00"
excWks.Range("A1:G1").Font.Name = "Arial"
excWks.Range("A1:G1").Font.Size = 10
excWks.Range("A1:G1").Font.Bold = True
excWks.Range("A1:G1").Interior.ColorIndex = 44
End With
rCount = rCount + 1
intRow = intRow + 1
'Write messages to spreadsheet
For Each olkMsg In Folder.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Subject = "*Stats @ 9:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("A" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 11:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("B" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 13:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("C" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 15:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("D" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 17:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("E" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 19:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("F" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 21:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("G" & rCount) = olkMsg.Body
End If
Next
Set olkMsg = Nothing
excWks.UsedRange.Columns.AutoFit
excWkb.Close True
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
End Sub
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt 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
Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function
Function SMTP2007(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function
The script in it's current form only exports the latest email from the folder and dumps it to the first column.
If I remove the
On Error Resume Next then I'm hit with a Run-time error '424' Object required
I don't know what I'm doing wrong and any help would be appreciated.
Looking for some help with an Outlook vb code.
I have the below code that I've put together but not getting the expected results.
I get a few emails a day with the a standard subject line Stats @ 9:00 18/10/2017, Stats @11:00 18/10/2017, Stats @ 13:00 18/10/2017, Stats @ 15:00 18/10/2017, Stats @ 17:00 18/10/2017, Stats @ 19:00 18/10/2017 and Stats @ 21:00 18/10/2017.
I'm trying to export each to a specific column in an excel file that I have created.
The vb code that I have is
Sub ExportMessagesToExcel()
Dim olkMsg As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
rCount As Long, _
intVersion As Integer
Dim subFolderName As String
MailboxName = "***@r***.com"
Pst_Folder_Name = "Inbox"
subFolderName = "stats"
Set Folder = Outlook.Session.Folders("***@***.com").Folders("Inbox").Folders("stats")
Const strPath As String = "B:\NCC\stats.xlsm" 'the path of the workbook
On Error Resume Next
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Open(strPath)
Set excWks = excWkb.Worksheets("Sheet1")
excWks.Range("A1:I1000").ClearContents
'Write Excel Column Headers
rCount = excWks.Range("D" & excWks.Rows.Count).End(-4162).Row
intRow = excWks.Range("A" & excWks.Rows.Count).End(-4162).Row
With excWks
excWks.Range("A" & 1).Value = "Stats @ 09:00"
excWks.Range("B" & 1).Value = "Stats @ 11:00"
excWks.Range("C" & 1).Value = "Stats @ 13:00"
excWks.Range("D" & 1).Value = "Stats @ 15:00"
excWks.Range("E" & 1).Value = "Stats @ 17:00"
excWks.Range("F" & 1).Value = "Stats @ 19:00"
excWks.Range("G" & 1).Value = "Stats @ 21:00"
excWks.Range("A1:G1").Font.Name = "Arial"
excWks.Range("A1:G1").Font.Size = 10
excWks.Range("A1:G1").Font.Bold = True
excWks.Range("A1:G1").Interior.ColorIndex = 44
End With
rCount = rCount + 1
intRow = intRow + 1
'Write messages to spreadsheet
For Each olkMsg In Folder.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Subject = "*Stats @ 9:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("A" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 11:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("B" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 13:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("C" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 15:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("D" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 17:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("E" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 19:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("F" & rCount) = olkMsg.Body
ElseIf olkMsg.Subject = "*Stats @ 21:00*%" And Format(olItem.ReceivedTime, "dd/MM/yyyy") = Int(Now) Then
excWks.Range("G" & rCount) = olkMsg.Body
End If
Next
Set olkMsg = Nothing
excWks.UsedRange.Columns.AutoFit
excWkb.Close True
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
End Sub
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt 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
Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function
Function SMTP2007(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function
The script in it's current form only exports the latest email from the folder and dumps it to the first column.
If I remove the
On Error Resume Next then I'm hit with a Run-time error '424' Object required
I don't know what I'm doing wrong and any help would be appreciated.