I am trying to import Outlook email data with VBA, and succeeded with this code:
Sub getMail()
Dim i As Long
Dim arrHeader As Variant
Dim olNS As Namespace
Dim olInboxFolder As MAPIFolder
Dim olItems As items
Dim olMailItem As MailItem
Dim objRept As ReportItem
arrHeader = Array("Date Created", "SenderEmailAddress", "Subject", "Body")
Set olNS = GetNamespace("MAPI")
Set olInboxFolder = olNS.PickFolder
Set olItems = olInboxFolder.items
Set olReportItem = olInboxFolder.items
Dim items, objects As Variant
items = Array(olMailItem, olReportItem)
objects = Array(MailItem, ReportItem)
i = 1
ThisWorkbook.Worksheets(2).Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
For Each olMailItem In olItems
ThisWorkbook.Worksheets(2).Cells(i + 1, "A").Value = olItems(i).CreationTime
ThisWorkbook.Worksheets(2).Cells(i + 1, "B").Value = olItems(i).SenderEmailAddress
ThisWorkbook.Worksheets(2).Cells(i + 1, "C").Value = olItems(i).Subject
ThisWorkbook.Worksheets(2).Cells(i + 1, "D").Value = olItems(i).Body
i = i + 1
Next olMailItem
ThisWorkbook.Worksheets(2).Cells.EntireColumn.AutoFit
MsgBox "Export complete.", vbInformation
Set olItems = Nothing
Set olInboxFolder = Nothing
Set olNS = Nothing
End Sub
This code imports only the mail items. Undelivered emails are known as reportitems and I am not able to make it work.
Your loop is using olMailItem which you have declared as a MailItem. Also, you are not going to be able to use ".SenderEmailAddress" on report items.
Try the following:
Sub getMail()
Dim i As Long
Dim arrHeader As Variant
Dim olNS As Namespace
Dim olInboxFolder As MAPIFolder
Dim olItems As items
Dim olItem As Variant
Set olNS = GetNamespace("MAPI")
Set olInboxFolder = olNS.PickFolder
Set olItems = olInboxFolder.items
arrHeader = Array("Date Created", "SenderEmailAddress", "Subject", "Body")
ThisWorkbook.Worksheets(2).Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
i = 1
For Each olItem In olItems
' MailItem
If olItem.Class = olMail Then
ThisWorkbook.Worksheets(2).Cells(i + 1, "A").Value = olItems(i).CreationTime
ThisWorkbook.Worksheets(2).Cells(i + 1, "B").Value = olItems(i).SenderEmailAddress
ThisWorkbook.Worksheets(2).Cells(i + 1, "C").Value = olItems(i).Subject
ThisWorkbook.Worksheets(2).Cells(i + 1, "D").Value = olItems(i).Body
' ReportItem
ElseIf olItem.Class = olReport Then
ThisWorkbook.Worksheets(2).Cells(i + 1, "A").Value = olItems(i).CreationTime
ThisWorkbook.Worksheets(2).Cells(i + 1, "B").Value = _
olItems(i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E") ' PR_SENDER_EMAIL_ADDRESS
ThisWorkbook.Worksheets(2).Cells(i + 1, "C").Value = olItems(i).Subject
End If
i = i + 1
Next olItem
ThisWorkbook.Worksheets(2).Cells.EntireColumn.AutoFit
MsgBox "Export complete.", vbInformation
Set olItems = Nothing
Set olInboxFolder = Nothing
Set olNS = Nothing
End Sub
Related
I'm trying to access calendar entries from 2 custom Outlook calendars using Excel VBA.
I've obtained some code which gives me what I want from the default calendar but I cannot see how to change the location to my own calendars.
The code I'm using is
Sub ListAppointments()
Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim olApt As Object
Dim nextrow As Long
Dim FromDate As Date
Dim ToDate As Date
FromDate = CDate("30/11/2021")
ToDate = CDate("20/12/2021")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(9)
nextrow = 2
With Sheets("Cal-Ext")
.Range("A1:E1").Value = Array("Date", "Start Time", "End Time", "Subject", "Location")
For Each olApt In olFolder.Items
If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
.Cells(nextrow, "A").Value = CDate(olApt.Start)
.Cells(nextrow, "A").NumberFormat = "DD/MM/YYYY"
.Cells(nextrow, "B").Value = olApt.Start
.Cells(nextrow, "B").NumberFormat = "HH:MM"
.Cells(nextrow, "C").Value = olApt.End
.Cells(nextrow, "C").NumberFormat = "HH:MM"
.Cells(nextrow, "D").Value = olApt.Subject
.Cells(nextrow, "E").Value = olApt.Location
nextrow = nextrow + 1
Else
End If
Next olApt
Set olFolder = olNS.GetDefaultFolder(9)
nextrow = nextrow + 5
For Each olApt In olFolder.Items
If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
.Cells(nextrow, "A").Value = CDate(olApt.Start)
.Cells(nextrow, "A").NumberFormat = "DD/MM/YYYY"
.Cells(nextrow, "B").Value = olApt.Start
.Cells(nextrow, "B").NumberFormat = "HH:MM"
.Cells(nextrow, "C").Value = olApt.End
.Cells(nextrow, "C").NumberFormat = "HH:MM"
.Cells(nextrow, "D").Value = olApt.Subject
.Cells(nextrow, "E").Value = olApt.Location
nextrow = nextrow + 1
Else
End If
Next olApt
.Columns.AutoFit
End With
Set olApt = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Sub
I need to change the set olfolder command before the second loop to select my own calendar but nothing I've tried works.
Outlook calendar
Current excel result
Here is a quick code that I wrote to loop through all the navigation folders of My Calendars
This code was tested in MS Outlook. You may have to edit it for it to work in MS Excel.
Option Explicit
Sub Sample()
Dim oNameSpace As Object
Dim oExplorer As Object
Dim oMainFolder As Object
Dim oCalModule As Object
Dim oSubFolder As Object
Dim oCalNavFolders As Object
Dim i As Long
Dim objitem As Object
Set oNameSpace = Outlook.GetNamespace("MAPI")
Set oExplorer = oNameSpace.GetDefaultFolder(9).GetExplorer
Set oCalModule = oExplorer.NavigationPane.Modules.GetNavigationModule(1)
Set oCalNavFolders = oCalModule.NavigationGroups.Item("My Calendars").NavigationFolders
For i = 1 To oCalNavFolders.Count
Set objitem = oCalNavFolders(i)
On Error Resume Next
Set oSubFolder = objitem.Folder
On Error GoTo 0
If Not oSubFolder Is Nothing Then
Debug.Print oSubFolder.Name
If oSubFolder.Name = "Area1" Then
With oSubFolder
'
'~~> Do what you want
'
End With
Exit For
End If
Set oSubFolder = Nothing
End If
Next i
End Sub
Screenshot
Code from Excel
Option Explicit
Sub ListAppointments()
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim oNameSpace As Object
Dim oExplorer As Object
Dim oMainFolder As Object
Dim oCalModule As Object
Dim oSubFolder As Object
Dim oCalNavFolders As Object
Dim i As Long
Dim objitem As Object
Set oNameSpace = OutApp.GetNamespace("MAPI")
Set oExplorer = oNameSpace.GetDefaultFolder(9).GetExplorer
Set oCalModule = oExplorer.NavigationPane.Modules.GetNavigationModule(1)
Set oCalNavFolders = oCalModule.NavigationGroups.Item("My Calendars").NavigationFolders
For i = 1 To oCalNavFolders.Count
Set objitem = oCalNavFolders(i)
On Error Resume Next
Set oSubFolder = objitem.Folder
On Error GoTo 0
If Not oSubFolder Is Nothing Then
Debug.Print oSubFolder.Name
If oSubFolder.Name = "Area1" Then
With oSubFolder
'
'~~> Do what you want
'
End With
Exit For
End If
Set oSubFolder = Nothing
End If
Next i
End Sub
I'd like to create an Outlook calendar meeting request each time a workbook is saved.
The meeting requests need to be added to a shared mailbox so that all users that have access see the meeting invite.
So far it adds an entry to my personal calendar.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("2021") 'define your sheet!
Dim olApp As Object 'create outlook application
Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object 'get namespace
Set olNS = olApp.GetNamespace("MAPI")
'define constants if using late binding
Const olFolderCalendar As Long = 9
Const olAppointmentItem As Long = 1
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
Dim strFilter As String 'filter for appointments
Dim olFilterRecItems As Object 'filtered appointments
Dim iRow As Long
iRow = 3
Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
'filter appointments for subject
strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
If olFilterRecItems.Count = 0 Then 'if subject does not exist
With olApp.CreateItem(olAppointmentItem)
.Subject = ws.Cells(iRow, 4).Value
.Start = ws.Cells(iRow, 3).Value
.AllDayEvent = True
.BusyStatus = 5
.ReminderSet = True
.Save
End With
ws.Cells(iRow, 3).Interior.ColorIndex = 50
End If
iRow = iRow + 1
Loop
End Sub
Update:
I managed to get this. The problem now is that it'll only create the calendar entry for the last line.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("2020") 'define your sheet!
Dim olApp As Object 'create outlook application
Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object 'get namespace
Set olNS = olApp.GetNamespace("MAPI")
Dim olAppItem As Outlook.AppointmentItem
Dim myRequiredAttendee As Outlook.Recipient
'define constants if using late binding
Const olFolderCalendar As Long = 9
Const olAppointmentItem As Long = 1
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
Set olAppItem = olRecItems.Items.Add(olAppointmentItem)
Dim strFilter As String 'filter for appointments
Dim olFilterRecItems As Object 'filtered appointments
Dim iRow As Long
iRow = 3
Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
'filter appointments for subject
strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
If olFilterRecItems.Count = 0 Then 'if subject does not exist
With olAppItem
Set myRequiredAttendee = .Recipients.Add("email address")
myRequiredAttendee.Type = olRequired
.MeetingStatus = olMeeting
.ReminderMinutesBeforeStart = 30
.Subject = ws.Cells(iRow, 4).Value
.Start = ws.Cells(iRow, 3).Value
.AllDayEvent = True
.BusyStatus = 5
.ReminderSet = True
.Send
End With
ws.Cells(iRow, 3).Interior.ColorIndex = 50
End If
iRow = iRow + 1
Loop
End Sub
Instead of the following code:
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
You need to use the NameSpace.GetSharedDefaultFolder method which returns a Folder object that represents the specified default folder for the specified user. This method is used in a delegation scenario, where one user has delegated access to another user for one or more of their default folders (for example, their shared Calendar folder). For example:
Sub ResolveName()
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.Folder
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Eugene Astafiev")
myRecipient.Resolve
If myRecipient.Resolved Then
Call ShowCalendar(myNamespace, myRecipient)
End If
End Sub
Sub ShowCalendar(myNamespace, myRecipient)
Dim CalendarFolder As Outlook.Folder
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub
I have the following code set up to create appointments in Outlook from data on my Excel spreadsheet. What I would like to do id make the appointment in a shared calendar rather than my own default one.
The calendar I want to add it to is the DTS Streetworks one as shown here - https://ibb.co/tKXKSPX, but I have no idea how to go about it.
Sub CoringAdd()
Dim OL As Outlook.Application, ES As Worksheet, _
r As Long, i As Long, wb As ThisWorkbook
Set wb = ThisWorkbook
Set ES = wb.Sheets("Coring")
Set OL = New Outlook.Application
r = ES.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To r
With ES.Cells(i, 10)
If .Value = "No" And ES.Cells(i, 7) <> "Yes" Then
ES.Cells(i, 7) = "Yes"
With OL.CreateItem(olAppointmentItem)
.Subject = "Send reminder email - LBRuT " + ES.Cells(i, 2).Value
.Start = ES.Cells(i, 6) + 1 + ES.Cells(i, 8).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = "£" & ES.Cells(i, 5).Value
.Save
End With
End If
End With
Next i
Set OL = Nothing
Set wb = Nothing
Set ES = Nothing
End Sub
UPDATE:
Latest code below, still goes to default calendar.
Sub ResolveName()
Dim OL As Outlook.Application, ES As Worksheet, _
r As Long, i As Long, wb As ThisWorkbook
Set wb = ThisWorkbook
Set ES = wb.Sheets("Licences")
Set OL = New Outlook.Application
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.MAPIFolder
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("DTS Streetworks")
myRecipient.Resolve
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
With Cells(i, 5)
If myRecipient.Resolved And .Value = "Mobile Plant" And Cells(i, 6) <> "" Then
With OL.CreateItem(olAppointmentItem)
.Subject = "Test " + ES.Cells(i, 4).Value
.Start = ES.Cells(i, 14) + ES.Cells(i, 15).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
End If
End With
Next i
End Sub
Sub ShowCalendar(myNamespace, myRecipient)
Dim CalendarFolder As Outlook.MAPIFolder
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub
You can get the shared calendar by using the NameSpace.GetSharedDefaultFolder method which returns a Folder object that represents the specified default folder for the specified user. For example:
Sub ResolveName()
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.MAPIFolder
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Eugene Astafiev")
myRecipient.Resolve
If myRecipient.Resolved Then
Call ShowCalendar(myNamespace, myRecipient)
End If
End Sub
Sub ShowCalendar(myNamespace, myRecipient)
Dim CalendarFolder As Outlook.MAPIFolder
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub
When you get a shared calendar folder you may use the Items.Add method which creates a new Outlook item in the Items collection for the folder. You just need to pass an item type you need to create, for example, olAppointmentItem.
Set myItem = mySharedCalendarFolder.Items.Add olAppointmentItem
So, your code should look like this:
Set wb = ThisWorkbook
Set ES = wb.Sheets("Licences")
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.MAPIFolder
Dim olAppItem as Outlook.AppointmentItem
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("DTS Streetworks")
myRecipient.Resolve
If myRecipient.Resolved Then
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
With Cells(i, 5)
If .Value = "Mobile Plant" And Cells(i, 6) <> "" Then
Set olAppItem = CalendarFolder.Items.Add olAppointmentItem
With olAppItem
.Subject = "Test " + ES.Cells(i, 4).Value
.Start = ES.Cells(i, 14) + ES.Cells(i, 15).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
End If
End With
Next i
End Sub
I have a macro that will get all emails that contains "HAPPY", "NEUTRAL" and "SAD" in the subject and copy it to a new sheet of the workbook. I want to add functionality to only display mood based on the date defined by a user.
Also, code below read emails in the inbox. I need it to read all the folders in my mailbox (e.g. Outbox and subfolders).
Sub GetMood()
Dim outlookApp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim myTasks
Dim sir() As String
Dim ws As Worksheet
Dim iRow As Variant
Dim d As Date
x = 2
d = ThisWorkbook.Sheets("Main").Cells(11, 7).Value
Set outlookApp = CreateObject("Outlook.Application")
Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
For Each olMail In myTasks
If (InStr(1, olMail.Subject, "HAPPY") > 0) Then
ThisWorkbook.Sheets("Report").Cells(1, 1) = "Sender"
ThisWorkbook.Sheets("Report").Cells(1, 2) = "Mood"
ThisWorkbook.Sheets("Report").Cells(1, 3) = "Date"
ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName
ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject
ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime
x = x + 1
ElseIf (InStr(1, olMail.Subject, "NEUTRAL") > 0) Then
ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName
ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject
ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime
x = x + 1
ElseIf (InStr(1, olMail.Subject, "SAD") > 0) Then
ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName
ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject
ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime
x = x + 1
'MsgBox "Report Generated", vbOKOnly
'Else
'olMail.Display
Exit For
End If
Next
End Sub
Private Sub Workbook_Open()
Worksheets("StartSheet").Activate
End Sub
This will look into every folders in Outlook and gather the information in mInfo to create a list in sheet Report.
I've modified the structure so that it'll detect if Outlook is already open, add a column with the detected mood and improve performances! ;)
Sub GetMood()
Dim wS As Excel.Worksheet
Dim outlookApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
'Dim sir() As String
'Dim iRow As Variant
'Dim d As Date
Dim RgPaste As Excel.Range
Dim mSubj As String
Dim mInfo() As Variant
Dim nbInfos As Integer
ReDim mInfo(1 To 1, 1 To 3)
nbInfos = UBound(mInfo, 2)
'd = ThisWorkbook.Sheets("Main").Cells(11, 7).Value
Set wS = ThisWorkbook.Sheets("Report")
With wS
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Mood"
.Cells(1, 3) = "Date"
Set RgPaste = .Cells(2, 1)
End With 'wS
Set outlookApp = GetObject(, "Outlook.Application")
If outlookApp Is Nothing Then Set outlookApp = CreateObject("Outlook.Application")
Set olNs = outlookApp.GetNamespace("MAPI")
For Each Fldr In olNs.Folders
For Each olMail In Fldr.Items
With olMail
mSubj = .Subject
mInfo(1, 1) = .SenderName
mInfo(1, 2) = mSubj
mInfo(1, 3) = .ReceivedTime
'.Display
End With 'olMail
With RgPaste
If (InStr(1, mSubj, "HAPPY") > 0) Then
.Resize(1, nbInfos).Value = mInfo
.Offset(0, nbInfos) = "HAPPY"
Set RgPaste = .Offset(1, 0)
ElseIf (InStr(1, mSubj, "NEUTRAL") > 0) Then
.Resize(1, nbInfos).Value = mInfo
.Offset(0, nbInfos) = "NEUTRAL"
Set RgPaste = .Offset(1, 0)
ElseIf (InStr(1, mSubj, "SAD") > 0) Then
.Resize(1, nbInfos).Value = mInfo
.Offset(0, nbInfos) = "SAD"
Set RgPaste = .Offset(1, 0)
End If
End With 'RgPaste
Next olMail
Next Fldr
'MsgBox "Report Generated", vbOKOnly
End Sub
I am trying to import dates in column "E" to my Outlook calendar.
I have code started, but it is only adding certain dates to my calendar and not adding what it seems to me like multiple dates for ex. The date of 6/2 is being added to my calendar with correct subject date and body, but for dates for 6/1 I have an empty slot.
Option Explicit
Public Sub CreateOutlookApptz()
Sheets("Sheet2").Select
On Error GoTo Err_Execute
Dim olApp As OUtlook.Application
Dim olAppt As OUtlook.AppointmentItem
Dim blnCreated As Boolean
Dim olNs As OUtlook.Namespace
Dim CalFolder As OUtlook.MAPIFolder
Dim subFolder As OUtlook.MAPIFolder
Dim arrCal As String
Dim i As Long
On Error Resume Next
Set olApp = OUtlook.Application
If olApp Is Nothing Then
Set olApp = OUtlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If
On Error GoTo 0
Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
i = 2
Do Until Trim(Cells(i, 1).Value) = ""
Set subFolder = CalFolder
Set olAppt = subFolder.Items.Add(olAppointmentItem)
MsgBox Cells(i, 6) + Cells(i, 7)
'MsgBox subFolder, vbOKCancel, "Folder Name"
With olAppt
'Define calendar item properties
.Start = Cells(i, 6) + Cells(i, 7)
.End = Cells(i, 8) + Cells(i, 9)
.Subject = Cells(i, 2)
.Location = Cells(i, 3)
.Body = Cells(i, 4)
.BusyStatus = olBusy
.ReminderMinutesBeforeStart = Cells(i, 10)
.ReminderSet = True
.Categories = Cells(i, 5)
.Save
End With
i = i + 1
Loop
Set olAppt = Nothing
Set olApp = Nothing
Exit Sub
Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."
End Sub
Try it this way.
Private Sub Add_Appointments_To_Outlook_Calendar()
'Include Microsoft Outlook nn.nn Object Library from Tools -> References
Dim oAppt As AppointmentItem
Dim Remind_Time As Double
i = 2
Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
'Loop through entire list of Reminders to be added
While Subj <> ""
Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)
oAppt.Subject = Subj
oAppt.Location = ThisWorkbook.Sheets(1).Cells(i, 2)
oAppt.Start = ThisWorkbook.Sheets(1).Cells(i, 3)
Remind_Time = ThisWorkbook.Sheets(1).Cells(i, 4) * 1 * 60
oAppt.ReminderMinutesBeforeStart = Remind_Time
oAppt.AllDayEvent = True
oAppt.Save
i = i + 1
Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
Wend
MsgBox "Reminder(s) Added To Outlook Calendar"
End Sub
Your setup will look something like this.
I talk about this concept, and many other similar, but different, things in my book.
https://www.amazon.com/Automating-Business-Processes-Reducing-Increasing-ebook/dp/B01DJJKVZC?ie=UTF8&keywords=ryan%20shuell&qid=1464361126&ref_=sr_1_1&sr=8-1