VBA Run-Time Error '-2147221233 (8004010f)' - vba

I am attempting to run the VBA code mentioned below.
The VBA code is for pulling email information from a single folder of the user's selection in Microsoft Outlook and listing what the response time is in Microsoft Excel.
Here is the error message I receive when I attempt to run it.
"Run-time error '-2147221233 (8004010f)':
The Property "http://schemas.microsoft.com/mapi/proptag/0x003F0102" is unknown or cannot be found.
Here is the code I am using:
Option Explicit
Public ns As Outlook.Namespace
Private Const EXCHIVERB_REPLYTOSENDER = 102
Private Const EXCHIVERB_REPLYTOALL = 103
Private Const EXCHIVERB_FORWARD = 104
Private Const PR_LAST_VERB_EXECUTED = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
Private Const PR_LAST_VERB_EXECUTION_TIME = "http://schemas.microsoft.com/mapi/proptag/0x10820040"
Private Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Private Const PR_RECEIVED_BY_ENTRYID As String = "http://schemas.microsoft.com/mapi/proptag/0x003F0102"
' Locates best matching reply in related conversation to the given mail message passed in as oMailItem
Private Function GetReply(oMailItem As MailItem) As MailItem
Dim conItem As Outlook.Conversation
Dim ConTable As Outlook.Table
Dim ConArray() As Variant
Dim MsgItem As MailItem
Dim lp As Long
Dim LastVerb As Long
Dim VerbTime As Date
Dim Clockdrift As Long
Dim OriginatorID As String
Set conItem = oMailItem.GetConversation ' Let Outlook and Exchange do the hard lifting to get entire converstion for email being checked.
OriginatorID = oMailItem.PropertyAccessor.BinaryToString(oMailItem.PropertyAccessor.GetProperty(PR_RECEIVED_BY_ENTRYID))
If Not conItem Is Nothing Then ' we have a conversation in which we should be able to match the reply
Set ConTable = conItem.GetTable
ConArray = ConTable.GetArray(ConTable.GetRowCount)
LastVerb = oMailItem.PropertyAccessor.GetProperty(PR_LAST_VERB_EXECUTED)
Select Case LastVerb
Case EXCHIVERB_REPLYTOSENDER, EXCHIVERB_REPLYTOALL ', EXCHIVERB_FORWARD ' not interested in forwarded messages
VerbTime = oMailItem.PropertyAccessor.GetProperty(PR_LAST_VERB_EXECUTION_TIME)
VerbTime = oMailItem.PropertyAccessor.UTCToLocalTime(VerbTime) ' convert to local time
' Debug.Print "Reply to " & oMailItem.Subject & " sent on (local time): " & VerbTime
For lp = 0 To UBound(ConArray)
If ConArray(lp, 4) = "IPM.Note" Then ' it is a mailitem
Set MsgItem = ns.GetItemFromID(ConArray(lp, 0)) 'mail item to check against
If Not MsgItem.Sender Is Nothing Then
If OriginatorID = MsgItem.Sender.ID Then
Clockdrift = DateDiff("s", VerbTime, MsgItem.SentOn)
If Clockdrift >= 0 And Clockdrift < 300 Then ' Allow for a clock drift of up to 300 seconds. This may be overgenerous
Set GetReply = MsgItem
Exit For ' only interested in first matching reply
End If
End If
End If
End If
Next
Case Else
End Select
End If
' as we exit function GetMsg is either Nothing or the reply we are interested in
End Function
Public Sub ListIt()
Dim myOlApp As New Outlook.Application
Dim myItem As Object ' item may not necessarily be a mailitem
Dim myReplyItem As Outlook.MailItem
Dim myFolder As Folder
Dim xlRow As Long
Set ns = myOlApp.GetNamespace("MAPI") ' Initialise Outlook access
Set myFolder = ns.PickFolder() ' for the sake of this example we just pick a folder.
InitSheet ActiveSheet ' initialise the spreadsheet
xlRow = 3
For Each myItem In myFolder.Items
If myItem.Class = olMail Then
Set myReplyItem = GetReply(myItem) ' this example only deals with mailitems
If Not myReplyItem Is Nothing Then ' we found a reply
PopulateSheet ActiveSheet, myItem, myReplyItem, xlRow
xlRow = xlRow + 1
End If
End If
DoEvents ' cheap and nasty way to allow other things to happen
Next
MsgBox "Done"
End Sub
Private Sub InitSheet(mySheet As Worksheet)
With mySheet
.Cells.Clear
.Cells(1, 1).FormulaR1C1 = "Received"
.Cells(2, 1).FormulaR1C1 = "From"
.Cells(2, 2).FormulaR1C1 = "Subject"
.Cells(2, 3).FormulaR1C1 = "Date/Time"
.Cells(1, 4).FormulaR1C1 = "Replied"
.Cells(2, 4).FormulaR1C1 = "From"
.Cells(2, 5).FormulaR1C1 = "To"
.Cells(2, 6).FormulaR1C1 = "Subject"
.Cells(2, 7).FormulaR1C1 = "Date/Time"
.Cells(2, 8).FormulaR1C1 = "Response Time"
End With
End Sub
Private Sub PopulateSheet(mySheet As Worksheet, myItem As MailItem, myReplyItem As MailItem, xlRow As Long)
Dim recips() As String
Dim myRecipient As Outlook.Recipient
Dim lp As Long
With mySheet
.Cells(xlRow, 1).FormulaR1C1 = myItem.SenderEmailAddress
.Cells(xlRow, 2).FormulaR1C1 = myItem.Subject
.Cells(xlRow, 3).FormulaR1C1 = myItem.ReceivedTime
'.Cells(xlRow, 4).FormulaR1C1 = myReplyItem.SenderEmailAddress
.Cells(xlRow, 4).FormulaR1C1 = myReplyItem.Sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS) ' I prefer to see the SMTP address
For lp = 0 To myReplyItem.Recipients.Count - 1
ReDim Preserve recips(lp) As String
recips(lp) = myReplyItem.Recipients(lp + 1).Address
Next
.Cells(xlRow, 5).FormulaR1C1 = Join(recips, vbCrLf)
.Cells(xlRow, 6).FormulaR1C1 = myReplyItem.Subject
.Cells(xlRow, 7).FormulaR1C1 = myReplyItem.SentOn
.Cells(xlRow, 8).FormulaR1C1 = "=RC[-1]-RC[-5]"
.Cells(xlRow, 8).NumberFormat = "[h]:mm:ss"
End With
End Sub
Can you help me out? Please let me know if I could be any more specific.

I noticed that the error occurs on the only line using the "as string" in the declaration. Although this type of declaration if perfectly fine in VB, it doesn't work in VBA.
Simply remove the "as string" on that line.

Related

How to extract Outlook email data from a specific sender in date and time sequence?

I extract data from Outlook email into Excel. The data is not extracted in sequence based on date and time.
The date format in my computer is ddmmyyyy format and the time zone is UK.
I want the date to be in one column and the time to be in another column.
Also I want to extract the email from sender email jkcopy#gmail.com.
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
' 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) = .SenderName
tempString(i + startRow, 2) = .ReceivedTime
tempString(i + startRow, 3) = .Subject
'tempString(i + startRow, 4) = Left$(.Body, 200) ' throws error without limit
'tempString(i + startRow, 5) = .SenderEmailAddress
'tempString(i + startRow, 6) = .SentOn
End With
' adding file attachment names where they exist - added by JP
If msg.Attachments.Count > 50 Then
For jAttach = 1 To msg.Attachments.Count
tempString(i + startRow, 39 + jAttach) = msg.Attachments.Item(jAttach).DisplayName
Next jAttach
End If
Next i
' first row of array should be header values
If headerRow Then
tempString(1, 1) = "SenderName"
tempString(1, 2) = "ReceivedTime"
tempString(1, 3) = "subject"
'tempString(1, 4) = "Body"
'tempString(1, 5) = "SenderEmailAddress"
'tempString(1, 6) = "SentOn"
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
You need to sort the items collections before iterating over all entries. The Items.Sort method sorts the collection of items by the specified property. The index for the collection is reset to 1 upon completion of this method.
The MailItem.ReceivedTime
which returns a Date indicating the date and time at which the item was received property can be used for sorting items in the folder.
mailFolderItems.Sort "[ReceivedTime]", False
' loop through folder items
For i = 1 To numRows
Set folderItem = mailFolderItems.Item(i)
Use the FormatDateTime function which returns an expression formatted as a date or time for your cells/rows.
The date/time format does not matter as long as you are adding the data as the DateTime type, not as a string (you do that part correctly).
If you want a particular order, you can either resort the data later in Excel, or you can sort the Items collection first by calling Items.Sort
Set mailFolderItems = strFolderName.Items
mailFolderItems.Sort "[ReceivedTime]", false

OutLook VBA Email or Notification Causes Out of Bounds Error

I have some outlook VBA code which works fine to save attachments, however every time I get an email or a meeting notification in Outlook it causes an instant Out of Bounds error If I don't get any emails or notifications the code will run fine through to completion.
Is there a way to ensure that these notifications will not stop the code from running?
Option Explicit
Sub SaveAttachmentsFromSelectedItemsPDF2_ForNext()
Dim currentItem As Object
Dim currentAttachment As Attachment
Dim saveToFolder As String
Dim savedFileCountPDF As Long
Dim i As Long
Dim j As Long
saveToFolder = "c:\dev\outlookexport" 'change the path accordingly
savedFileCountPDF = 0
For i = 1 To ActiveExplorer.Selection.Count
Set currentItem = ActiveExplorer.Selection(i)
For j = 1 To currentItem.Attachments.Count
Set currentAttachment = currentItem.Attachments(j)
If UCase(Right(currentAttachment.DisplayName, 5)) = UCase(".xlsx") Then
currentAttachment.SaveAsFile saveToFolder & "\" & _
Left(currentAttachment.DisplayName, Len(currentAttachment.DisplayName) - 5) & ".xlsx"
savedFileCountPDF = savedFileCountPDF + 1
End If
' If For Next does not release memory automatically then
' uncomment to see if this has an impact
'Set currentAttachment = Nothing
Next
' If For Next does not release memory automatically then
' uncomment to see if this has an impact
'Set currentItem = Nothing
Next
MsgBox "Number of PDF files saved: " & savedFileCountPDF, vbInformation
End Sub
This is what I tried to create from the answer below:
Option Explicit
Sub SaveAttachmentsFromSelectedItemsPDF2_ForNext()
Dim currentItem As Object
Dim currentAttachment As Attachment
Dim saveToFolder As String
Dim savedFileCountPDF As Long
Dim i As Long
Dim j As Long
Dim x As Long
Dim myOlExp As Object
Dim myOlSel As Object
' New
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
saveToFolder = "c:\dev\outlookexport" 'change the path accordingly
savedFileCountPDF = 0
For x = 1 To myOlSel.Count
If myOlSel.Item(x).Class = OlObjectClass.olMail Then
Set currentItem = ActiveExplorer.Selection(i)
For j = 1 To currentItem.Attachments.Count
Set currentAttachment = currentItem.Attachments(j)
If UCase(Right(currentAttachment.DisplayName, 5)) = UCase(".xlsx") Then
currentAttachment.SaveAsFile saveToFolder & "\" & _
Left(currentAttachment.DisplayName, Len(currentAttachment.DisplayName) - 5) & ".xlsx"
savedFileCountPDF = savedFileCountPDF + 1
End If
Next
End If
Next
MsgBox "Number of PDF files saved: " & savedFileCountPDF, vbInformation
End Sub
The Selection property of the Explorer class returns a Selection object that contains the item or items that are selected in the explorer window. In your code I've noticed the following lines of code:
For i = 1 To ActiveExplorer.Selection.Count
Set currentItem = ActiveExplorer.Selection(i)
So, if the selection is changed in Outlook between these two lines of code you may get out of range exception at runtime. Instead, I'd recommend caching the selection object and use it through the code to make sure it remains the same:
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
For x = 1 To myOlSel.Count
If myOlSel.Item(x).Class = OlObjectClass.olMail Then
' do something here
End If
Next
Another important thing is that a folder may contain different types of items. You'd need to check their message class to distinguish different kind of Outlook items.

Need help in loop function in vba to send multiple emails

I have a Excel VBA (Send_Mail) to send emails thru Lotus Notes. It is working fine, however I need help in sending individual email to multiple people in one go.
In my excel sheet. Cell A7 downwards will be the email addresses that can go upto 200+ rows, B7 has the subject Line and Cell C7 has the body of email. (all of this is getting auto populated with a different macro). However my code (Send_Mail) is just sending one email to the address which is in cell A7. I need your help in sending mail to all the email address that are in Col A7 onwards with its respective subject (Col B) and mail body (col C)
Below is my code.
Public TOID As String
Public CCID As String
Public SECT As String
Public ACCO As String
Public SUBJ As String
Sub Send_Mail()
Dim answer As Integer
answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ?? Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES")
If answer = vbNo Then
MsgBox "Please Open Notes and Try the Macro Again"
Exit Sub
Else
End If
Application.DisplayAlerts = False
Call Send
MsgBox "Mail Sent to " & (Range("L2").Value) & " " & "Recipents"
Application.DisplayAlerts = True
End Sub
Public Function Send()
SendEMail = True
Sheets("Main").Select
TOID = Range("A7").Value
CCID = ""
SUBJ = Range("B7").Value
'On Error GoTo ErrorMsg
Dim EmailList As Variant
Dim ws, uidoc, Session, db, uidb, NotesAttach, NotesDoc, objShell As Object
Dim RichTextBody, RichTextAttachment As Object
Dim server, mailfile, user, usersig As String
Dim SubjectTxt, MsgTxt As String
Set Session = CreateObject("Notes.NotesSession")
user = Session.UserName
usersig = Session.COMMONUSERNAME
mailfile = Session.GETENVIRONMENTSTRING("MailFile", True)
server = Session.GETENVIRONMENTSTRING("MailServer", True)
Set db = Session.GETDATABASE(server, mailfile)
If Not db.IsOpen Then
Call db.Open("", "")
Exit Function
End If
Set NotesDoc = db.CREATEDOCUMENT
With NotesDoc
.Form = "Memo"
.Subject = SUBJ 'The subject line in the email
.Principal = user
.sendto = TOID 'e-mail ID variable to identify whom email need to be sent
.CopyTo = CCID
End With
Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body")
With NotesDoc
.COMPUTEWITHFORM False, False
End With
'==Now set the front end stuff
Set ws = CreateObject("Notes.NotesUIWorkspace")
If Not ws Is Nothing Then
Set uidoc = ws.EDITDOCUMENT(True, NotesDoc)
If Not uidoc Is Nothing Then
If uidoc.EDITMODE Then
'Mail Body
Sheets("Main").Select
Range("C7").Select
Dim rnBody1 As Range
Set rnBody1 = Selection
rnBody1.CopyPicture
'rnBody1.Copy
Call uidoc.GOTOFIELD("Body")
Call uidoc.Paste
End If
End If
End If
Call uidoc.Send
Call uidoc.Close
'close connection to free memory
Set Session = Nothing
Set db = Nothing
Set NotesAttach = Nothing
Set NotesDoc = Nothing
Set uidoc = Nothing
Set ws = Nothing
Sheets("Main").Select
End Function
I am worried about confusing you with too much new detail and must profess i haven't tested the following code so please don't assume this will solve your problem outright.
The following gives you an idea of how you might use a loop as you requested. See example also here which covers instances where you might need to batch send (admittedly link is for Outlook) and is also an example of using a loop.
I have included some explanations along the way in the code. It is difficult without more information to properly tailor this but i hope it helps.
Option Explicit
Public TOID As String
Public CCID As String
Public SECT As String
Public ACCO As String
Public SUBJ As String
Public Sub Send_Mail()
Dim wb As Workbook
Dim ws1 As Worksheet
Set wb = ThisWorkbook 'These are assumptions
Set ws1 = wb.Worksheets("Sheet1") 'These are assumptions. You would change as necessary
Dim answer As Long 'Integer types changed to Long
answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ?? Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES")
If answer = vbNo Then
MsgBox "Please Open Notes and Try the Macro Again"
Exit Sub
'Else 'Not being used so consider removing
End If
Application.DisplayAlerts = False
Dim lRow As Long
Dim loopRange As Range
Dim currentRow As Long
Dim TOIDvar As String
Dim SUBJvar As String
With ws1
lRow = .Range("A7").End(xlDown).Row 'Assume no gaps in column A in the TOID range
Set loopRange = .Range("A7:A" & lRow)
For currentRow = 1 To loopRange.Rows.Count 'Loop range assigning values to arguments and call send sub with args
TOIDvar = loopRange.Cells(currentRow, 1)
SUBJvar = loopRange.Cells(currentRow, 1).Offset(0, 1) ' get column B in same row using Offset
Send TOIDvar, SUBJvar
Next currentRow
End With
'Commented out MsgBox at present as unsure what you will do when sending multiple e-mails
'MsgBox "Mail Sent to " & (ws1.Range("L2").Value) & " " & "Recipents" 'use explicit fully qualified Range references
Application.DisplayAlerts = True
End Sub
Public Sub Send(ByVal TOIDvar As String, ByVal SUBJvar As String) 'changed to sub using arguments
Dim SendEMail As Boolean 'declare with type
Dim wb As Workbook
Dim ws2 As Worksheet
Set wb = ThisWorkbook 'These are assumptions. Ensuring you are working with correct workbook
Set ws2 = wb.Worksheets("Main")
SendEMail = True
TOID = TOIDvar
CCID = vbNullString 'use VBNullString rather than empty string literals
SUBJ = SUBJvar
'On Error GoTo ErrorMsg
Dim EmailList As Variant 'declaration of separate lines and with their types
Dim ws As Object
Dim uidoc As Object
Dim Session As Object
Dim db As Object
Dim uidb As Object
Dim NotesAttach As Object
Dim NotesDoc As Object
Dim objShell As Object
Dim RichTextBody As Object
Dim RichTextAttachment As Object
Dim server As String
Dim mailfile As String
Dim user As String
Dim usersig As String
Dim SubjectTxt As String
Dim MsgTxt As String
Set Session = CreateObject("Notes.NotesSession")
user = Session.UserName
usersig = Session.COMMONUSERNAME
mailfile = Session.GETENVIRONMENTSTRING("MailFile", True)
server = Session.GETENVIRONMENTSTRING("MailServer", True)
Set db = Session.GETDATABASE(server, mailfile)
If Not db.IsOpen Then
db.Open vbNullString, vbNullString
Exit Sub
End If
Set NotesDoc = db.CREATEDOCUMENT
With NotesDoc
.Form = "Memo"
.Subject = SUBJ 'The subject line in the email
.Principal = user
.sendto = TOID 'e-mail ID variable to identify whom email need to be sent
.CopyTo = CCID
End With
Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body")
With NotesDoc
.COMPUTEWITHFORM False, False
End With
'==Now set the front end stuff
Set ws = CreateObject("Notes.NotesUIWorkspace")
If Not ws Is Nothing Then
Set uidoc = ws.EDITDOCUMENT(True, NotesDoc)
If Not uidoc Is Nothing Then
If uidoc.EDITMODE Then
'Mail Body
With ws2.Range("C7")
Dim rnBody1 As Range
Set rnBody1 = .Value2
rnBody1.CopyPicture
'rnBody1.Copy
uidoc.GOTOFIELD "Body"
uidoc.Paste
End With
End If
End If
End If
uidoc.Send
uidoc.Close
'removed garbage collection
ws2.Activate ' swopped out .Select and used Worksheets collection held in variable ws2
End Sub
You may want to consider this.
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
See this link for all details.
https://www.rondebruin.nl/win/s1/outlook/amail6.htm

Outlook Export Custom Field to Excel

I have a module that I had used in the past to pull data from my outlook calendar and was putting basically “billing” information into the location field so I didn’t have to do a custom field. Of course that kind of worked until someone sent an invite using location … so I needed to evolve and create a new field. My problem is now of course my VBA must change to use custom fields.
Below is what I have – the “BillingInfo” or the following
.End(xlDown).End(xlUp).Offset(NextRow, 3).Value = ThisAppt.BillingInfo is what is getting flagged.
here is the full ...
' this is the sub to tell outlook what to pull in -
' select the dates as needed
'
Sub GetApptsFromOutlook()
Dim dteStart As Date
Dim dteEnd As Date
dteStart = InputBox("What is the start date?")
dteEnd = InputBox("What is the end date?")
Call GetCalData(dteStart, dteEnd)
End Sub
Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)
' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
' Make sure to reference the Outlook object library before running the code
' End Date is optional, if you want to pull from only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim myCalItems As Outlook.Items
Dim ItemstoCheck As Outlook.Items
Dim ThisAppt As Outlook.AppointmentItem
Dim MyItem As Object
Dim StringToCheck As String
Dim MyBook As Excel.Workbook
Dim rngStart As Excel.Range
Dim i As Long
Dim NextRow As Long
' if no end date was specified, then the requestor only wants one day, so set EndDate = StartDate
' this will let us return appts from multiple dates, if the requestor does in fact set an appropriate end date
If EndDate = "12:00:00 AM" Then
EndDate = StartDate
End If
If EndDate < StartDate Then
MsgBox "Those dates seem switched, please check them and try again.", vbInformation
GoTo ExitProc
End If
If EndDate - StartDate > 28 Then
' ask if the requestor wants so much info
If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
GoTo ExitProc
End If
End If
' get or create Outlook object and make sure it exists before continuing
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
GoTo ExitProc
End If
Set olNS = olApp.GetNamespace("MAPI")
Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Items
' ------------------------------------------------------------------
' the following code adapted from:
' http://www.outlookcode.com/article.aspx?id=30
'
With myCalItems
.Sort "[Start]", False
.IncludeRecurrences = True
End With
'
StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & " AND [End] <= " & _
Quote(EndDate & " 11:59 PM")
Debug.Print StringToCheck
'
Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
Debug.Print ItemstoCheck.Count
' ------------------------------------------------------------------
If ItemstoCheck.Count > 0 Then
' we found at least one appt
' check if there are actually any items in the collection, otherwise exit
If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
Set MyBook = Excel.Workbooks.Add
Set rngStart = MyBook.Sheets(1).Range("A1")
With rngStart
.Offset(0, 0).Value = "Start"
.Offset(0, 1).Value = "Duration"
.Offset(0, 2).Value = "Categories"
.Offset(0, 3).Value = "BillingInfo"
.Offset(0, 4).Value = "Subject"
End With
For Each MyItem In ItemstoCheck
If MyItem.Class = olAppointment Then
' MyItem is the appointment or meeting item we want,
' set obj reference to it
Set ThisAppt = MyItem
NextRow = WorksheetFunction.CountA(Range("A:A"))
With rngStart
.End(xlDown).End(xlUp).Offset(NextRow, 0).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
.End(xlDown).End(xlUp).Offset(NextRow, 1).Value = ThisAppt.Duration
.End(xlDown).End(xlUp).Offset(NextRow, 2).Value = ThisAppt.Categories
.End(xlDown).End(xlUp).Offset(NextRow, 3).Value = ThisAppt.BillingInfo
.End(xlDown).End(xlUp).Offset(NextRow, 4).Value = ThisAppt.Subject
If ThisAppt.Categories <> "" Then
.End(xlDown).End(xlUp).Offset(NextRow, 6).Value = ThisAppt.Categories
Else
.End(xlDown).End(xlUp).Offset(NextRow, 6).Value = "n/a"
End If
End With
End If
Next MyItem
' make it pretty
Call Cool_Colors(rngStart)
Else
MsgBox "There are no appointments or meetings during" & _
"the time you specified. Exiting now.", vbCritical
End If
ExitProc:
Set myCalItems = Nothing
Set ItemstoCheck = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set rngStart = Nothing
Set ThisAppt = Nothing
End Sub
Private Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
Quote = Chr(34) & MyText & Chr(34)
End Function
Private Sub Cool_Colors(rng As Excel.Range)
'
' Lt Blue BG with white letters
'
'
With Range(rng, rng.End(xlToRight))
.Font.ColorIndex = 2
.Font.Bold = True
.HorizontalAlignment = xlCenter
.MergeCells = False
.AutoFilter
.CurrentRegion.Columns.AutoFit
With .Interior
.ColorIndex = 41
.Pattern = xlSolid
End With
End With
End Sub
ThisAppt does not contains BillingInfo directly. You will need to retrieve it through the UserProperties collection like this :
.End(xlDown).End(xlUp).Offset(NextRow, 3).Value = ThisAppt.UserProperties.Item("BillingInfo").Value

Runtime error looping through Outlook items

I am using VBA in Outlook to extract mail information from items in the mainfolder and subfolder. The mainfolder failed to set(capture) the subfolder properties into it and it causes the runtime error.
The runtime error differs whenever I run. For example, sometime I received -970718969 (c6240107) and another time I received -2044460793 (86240107).
When I clicked debug, it points to this line of code:
For Each itm In subFld.Items
Here is the screenshot:
Here is the full code:
Public monthValue As Integer
Public yearValue As String
'Ensure Microsoft Excel 11.0 Object Library is ticked in tools.
Sub ExportToExcel1()
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim mainFld As Outlook.MAPIFolder
Dim subFld As Outlook.MAPIFolder
Dim itm As Object
Dim offsetRow As Long
Dim emailCount As Long
'Set the path of the excel file.
strSheet = "For fun.xlsx"
strPath = "C:\Users\xxxxxx\Desktop\xxxxx\"
strSheet = strPath & strSheet
Debug.Print strSheet
Set nms = Application.GetNamespace("MAPI")
Set mainFld = nms.PickFolder 'Open the box to select the file.
'Handle potential errors with Select Folder dialog box.
If mainFld Is Nothing Then
MsgBox "Thank you for using this service.", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
ElseIf mainFld.DefaultItemType <> olMailItem Then
MsgBox "Please select the correct folder.", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
ElseIf mainFld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
End If
mainForm.Show
'If user clicks cancel, it will exit sub.
If yearValue = "" Then
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True 'Show my workbook.
'Check if there are any subfolders.
If mainFld.Folders.Count = 0 Then '1
'No subfolder.
For Each itm In mainFld.Items
If itm.Class <> olMail Then '2
'do nothing
Else
Set msg = itm
'Validate the month and year for the email.
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '3
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount 'Track the number of email.
Else
'Do nothing
End If '3
End If '2
Next itm
Else
'With subfolder
For Each itm In mainFld.Items
If itm.Class <> olMail Then '4
'do nothing
Else
Set msg = itm
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '5
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount
Else
'Do nothing
End If '5
End If '4
Next itm
For Each subFld In mainFld.Folders
For Each itm In subFld.Items
If itm.Class <> olMail Then '6
'do nothing
Else
Set msg = itm
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '7
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount
Else
'Do nothing
End If '7
End If '6
Next itm
Next subFld
End If '1
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing
'Inform the user that there are no email.
If emailCount = 0 Then
MsgBox "No emails associated with this date: " & MonthName(monthValue, True) & " " & yearValue, vbOKOnly, "No Emails"
End If
Exit Sub
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing
End Sub
Do you get that error immediately or only after processing a large number of items? Most likely you are opening too many items and run out of RPC channels. Is this a cached or an online Exchange profile?
Instead of looping through all items, use the Table object (MAPITable.GetTable) - if nothing else, it will be a lot faster.
EDIT: If you are using Exchange, every store object (message, folder, store) opens an RPC channel. Exchange Server limits the number of RPC channels to 255 per client (can be changed on the server). Do not use "for each" loop (it keeps all items referenced until the loop ends) and avoid multiple dot notation (because you will have implicit variables that you cannot explicitly dereference). You will also need to release all Outlook objects as soon as you are done with them.
set fldItems = mainFld.Items
For i = 1 to fldItems.Count do
set itm = fldItems.Item(i)
'do stuff
set itm = Nothing
next
As for the Table object (introduced in Outlook 2007), see http://msdn.microsoft.com/en-us/library/office/ff860769.aspx. If you need to use this in an earlier version of Outlook, you can use the MAPITable object in Redemption (I am its author); it also has a MAPITable.ExecSQL method that takes a standard SQL query and returns the ADODB.Recordset object.