I am writing code that will take a set of dates and invitees from Excel and import them into Outlook, so they can be imported into Sharepoint, so they can be synchronized across multiple people and get popup alerts on Outlook and their mobile devices.

I am aware this is probably the most convoluted solution ever, but mostly dealing with low-tech users and need to get down to a single button-click to automate the process, which I have done!

But the catch is, it works on my computer, and all of my coworkers I've tried it on, but it doesn't work on my boss' computer - he recently upgraded his computer and has Outlook 2013 if that matters. The error message in question is the infamous "cannot send because the message has been changed." I looked online and found a potential workaround using .display and .sendkeys {enter} instead of .send, but it returned the same message.

The code is as follows:

Sub RunScheduler()
Application.ScreenUpdating = False
Dim exlApp As Excel.Application
Dim exlWkb As Workbook
Dim exlSht As Worksheet
Dim outApp As Outlook.Application
Dim rng As Range
Dim strFilepath As String
Dim myPerson1, myPerson2, myPerson3, myPerson4, myPerson5, myPerson6, myPerson7, myPerson8, myPerson9, myPerson10 As Outlook.Recipient
Dim intPeople, intPcount As Integer
Dim itmTask As Outlook.TaskItem
Dim itmAppt As Outlook.AppointmentItem
Dim aptPtrn As Outlook.RecurrencePattern
Dim cnct As ContactItem
Dim fso As FileSystemObject
Dim fl As File
Set exlApp = GetObject(, "excel.application")
On Error Resume Next
Set outApp = GetObject(, "outlook.application")
'If outApp = Nothing Then Set outApp = CreateObject("Outlook.Application")
On Error GoTo 0
Dim strJobno, strFoldid, strUsername As String

strUsername = GetUserName

With exlApp
strFilepath = exlApp.ActiveWorkbook.FullName
Set exlSht = ActiveWorkbook.Worksheets(1)
Dim iRow As Integer
Dim iCol As Integer
End With

strJobno = exlSht.Cells(2, 2)

With outApp
Dim tmpItm As Outlook.Link
Dim mpiFolder As MAPIFolder
Dim oNs As Namespace
Set oNs = Outlook.GetNamespace("MAPI")
Set mpiFolder = oNs.GetDefaultFolder(olFolderContacts)
End With

Dim olTarfolder As Outlook.MAPIFolder
Set olTarfolder = outApp.GetNamespace("MAPI").PickFolder
olTarfolder.Display
strFoldid = olTarfolder.EntryID

iRow = 7
iCol = 1

While exlSht.Cells(iRow, iCol) <> ""
If exlSht.Cells(iRow, iCol) = "Meeting" Then
Set itmAppt = oNs.GetFolderFromID(strFoldid).Items.Add(olAppointmentItem)
itmAppt.MeetingStatus = olMeeting
Set intPeople = exlSht.Cells(iRow, 3)
itmAppt.Subject = strJobno + " - " + exlSht.Cells(iRow, 2)
intPcount = 1
For intPcount = 1 To intPeople
Set cnct = mpiFolder.Items.Find("[FullName] = " & exlSht.Cells(iRow, 7 + intPcount))
If cnct Is Nothing Then
Set cnct = Outlook.CreateItem(olContactItem)
cnct.FullName = exlSht.Cells(iRow, 7 + intPcount)
cnct.Save
End If
itmAppt.Recipients.Add (exlSht.Cells(iRow, 7 + intPcount))
Next intPcount
itmAppt.Categories = exlSht.Cells(iRow, 4)
itmAppt.Start = exlSht.Cells(iRow, 6)
itmAppt.End = exlSht.Cells(iRow, 7)
itmAppt.AllDayEvent = False
itmAppt.Links.Add cnct <-----THE OTHER LINE I'M ASKING ABOUT
Select Case exlSht.Cells(iRow, 5)
Case "No Reminder"
itmAppt.ReminderSet = False
Case "0 Minutes"
itmAppt.ReminderSet = True
itmAppt.ReminderMinutesBeforeStart = 0
Case "1 Day"
itmAppt.ReminderSet = True
itmAppt.ReminderMinutesBeforeStart = 1440
Case "2 Days"
itmAppt.ReminderSet = True
itmAppt.ReminderMinutesBeforeStart = 2880
Case "1 Week"
itmAppt.ReminderSet = True
itmAppt.ReminderMinutesBeforeStart = 10080
Case "1 Hour"
itmAppt.ReminderSet = True
itmAppt.ReminderMinutesBeforeStart = 60
End Select
itmAppt.Save
itmAppt.Send <----ERROR HERE
itmAppt.Close olSave
Set itmAppt = Nothing
iRow = iRow + 1
End If
If exlSht.Cells(iRow, iCol) = "Task" Then
Set itmTask = oNs.GetFolderFromID(strFoldid).Items.Add(olTaskItem)
itmTask.Assign
itmTask.Subject = strJobno + " - " + exlSht.Cells(iRow, 8) + " - " + exlSht.Cells(iRow, 2)
Set cnct = mpiFolder.Items.Find("[FullName] = " & exlSht.Cells(iRow, 8))
If cnct Is Nothing Then
Set cnct = Outlook.CreateItem(olContactItem)
cnct.FullName = exlSht.Cells(iRow, 8)
cnct.Save
End If
itmTask.Recipients.Add (exlSht.Cells(iRow, 8))
itmTask.StartDate = exlSht.Cells(iRow, 6)
itmTask.DueDate = exlSht.Cells(iRow, 7)
Select Case exlSht.Cells(iRow, 5)
Case "No"
itmTask.ReminderSet = False
Case "Yes"
itmTask.ReminderSet = True
End Select
itmTask.Body = "You have been assigned the task " & exlSht.Cells(iRow, 2) & " by " & Application.UserName & " for Job Number " & strJobno
itmTask.Display
itmTask.Save
If strUsername = exlSht.Cells(iRow, 8) Then GoTo 1
On Error Resume Next
itmTask.Send
On Error GoTo 0
1: itmTask.Close olSave
Set itmTask = Nothing
iRow = iRow + 1
End If
Wend
outApp.ActiveWindow.Close
Application.ScreenUpdating = True
End Sub

Incidentally the itmAppt.Links.Add cnct line marked gives his computer fits as well, but it seems to not hurt anything to just comment it out on his version.