Importing Calendar Items to Outlook (VBA/Excel)
- Details
- Category: Scripts and Code
- Published on Thursday, 09 April 2015 23:52
- Written by Christian Dunn
Microsoft Outlook includes an import/export feature that can be used to create calendar items from a spreadsheet. This method however only works on your primary mailbox.
If you have direct access to your shared mailboxes or exchange server there are other solutions but as a user this makes it difficult to automatically create calendar items in a shared mailbox. Looking for a solution I discovered an easy way to create a VBA macro that could be used to select and create calendar items in any of my mailboxes. Simply populate this spreadsheet and run the import and you can watch as calendar items are created and meeting requests automatically sent.
The VBA code is quite simple and shown below. You can also download the attached Macro Enabled Excel Workbook for Excel 2007/2010/2013 to test this out. To assist in debugging you can uncomment the additional lines to provide notification prompts as each value is selected. Sample data is included in the spreadsheet to show usage.
Dim iRowDim iProcessedDim iAddediRow = 5iProcessed = 0iAdded = 0Dim OLApp As ObjectDim OLNSF As ObjectDim OLAppointment As ObjectOn Error Resume NextSet OLApp = GetObject(, "Outlook.Application")If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")On Error GoTo 0If Not OLApp Is Nothing ThenSet OLNSF = OLApp.GetNamespace("MAPI").PickFolderIf Not OLNSF Is Nothing ThenWhile Cells(iRow, 1) <> ""If Cells(iRow, 2) <> "" ThenSet OLAppointment = OLNSF.Items.Add'MsgBox "1"OLAppointment.Subject = Cells(iRow, 1).Value'MsgBox "2-3"OLAppointment.Start = FormatDateTime(Cells(iRow, 2).Value, vbShortDate) & " " & FormatDateTime(Cells(iRow, 3).Value, vbLongTime)'MsgBox "4-5"OLAppointment.End = FormatDateTime(Cells(iRow, 4).Value, vbShortDate) & " " & FormatDateTime(Cells(iRow, 5).Value, vbLongTime)'MsgBox "6"OLAppointment.AllDayEvent = CBool(Cells(iRow, 6).Value)'MsgBox "7"OLAppointment.Body = Cells(iRow, 7).Value'MsgBox "8"OLAppointment.Location = Cells(iRow, 8).Value'MsgBox "9"OLAppointment.Categories = Cells(iRow, 9).Value'MsgBox "10"OLAppointment.RequiredAttendees = Cells(iRow, 10).Value'MsgBox "11"OLAppointment.OptionalAttendees = Cells(iRow, 11).Value'MsgBox "12"If Cells(iRow, 12).Value = 1 Then OLAppointment.MeetingStatus = 1'MsgBox "13"OLAppointment.ResponseRequested = CBool(Cells(iRow, 13).Value)OLAppointment.SendOLAppointment.SaveiAdded = iAdded + 1End IfiProcessed = iProcessed + 1iRow = iRow + 1WendMsgBox iProcessed & " records processed and " & iAdded & " appointments created."End IfEnd IfSet OLAppointment = NothingSet OLNSF = NothingSet OLApp = Nothing