I'm creating a spreadsheet application to write appointments to
Outlook. It writes the first appoitnment in the sheet OK. When it goes
to .Save the second down I get the "operation cannot be performed
because the message has been changed" error

Any ideas how I fix.

Thanks in advance. Here's my code

Sub SetAppt()

'// Initial Setup //
Dim olApp As Outlook.Application
Dim olApt As AppointmentItem

Set olApp = New Outlook.Application
Set olApt = olApp.CreateItem(olAppointmentItem)

Dim xLabel As Integer
qTitle = "ExcelToOutlookTaskSynch"

'// If any, how many records do we need to process? //
qrow = [B20].End(xlDown).Row
If qrow = 65536 Then Exit Sub 'No records

'// Loop through records //
For i = 21 To qrow
'// Pick up and translate variables //
qID = Cells(i, 1)
qTask = Cells(i, 2)
qDesc = Cells(i, 3)
qStartDay = Cells(i, 4)
qStartTime = Cells(i, 5)
qEndDay = Cells(i, 6)
qEndTime = Cells(i, 7)
qLabel = Cells(i, 8)
qShowAs = Cells(i, 9)
'// Translate qShowAs //
If qShowAs = "Busy" Then qShowAs = Outlook.OlBusyStatus.olBusy
If qShowAs = "Free" Then qShowAs = Outlook.OlBusyStatus.olFree
If qShowAs = "Tentative" Then qShowAs =
Outlook.OlBusyStatus.olTentative
If qShowAs = "Out of office" Then qShowAs =
Outlook.OlBusyStatus.olOutOfOffice
qLocation = Cells(i, 10)
qResource = Cells(i, 11)
qTo = Cells(i, 12)
qWaitTime = Cells(i, 13)
qSentTo = Cells(i, 14)
'// Pick up and translate variables //

'// Validation //
'// qID //
If Not IsNumeric(qID) Or qID 0 Then
MsgBox "qID: " & qID & " not a Valid Positive Integer.
Please correct.", vbCritical, qTitle
Exit Sub
End If
' // qTask //
If qTask = "" Then
MsgBox "Please enter a Task for appointment: " & qID,
vbCritical, qTitle
Exit Sub
End If
'// qStartDay //
If Not IsDate(qStartDay) Then
MsgBox "Please enter a valid start date for appointment: "
& qID, vbCritical, qTitle
Exit Sub
End If
'// qStartTime //
If qStartTime 1 Or qStartTime 0 Then
MsgBox "Please enter a valid start time for appointment: "
& qID, vbCritical, qTitle
Exit Sub
End If
'// qEndDay //
If Not IsDate(qEndDay) Then
MsgBox "Please enter a valid end date for appointment: " &
qID, vbCritical, qTitle
Exit Sub
End If
'// qEndTime //
If qEndTime 1 Or qEndTime 0 Then
MsgBox "Please enter a valid end time for appointment: " &
qID, vbCritical, qTitle
Exit Sub
End If
'// qLabel //
If qLabel = "" Then
MsgBox "Please enter a valid Label from the drop down box
for appointment: " & qID, vbCritical, qTitle
Exit Sub
End If
'// qShowAs //
If qShowAs = "" Then
MsgBox "Please enter a valid 'Show As' category from the
drop down box for appointment: " & qID, vbCritical, qTitle
Exit Sub
End If
'// Validation //

'// Determine whether or not to transmit to Outlook and write//
If qSentTo "Y" Then
'// Determine whether or not to postpone the current item //
If qWaitTime 0 Then
'// Records time to wait until //
newHour = Hour(Now())
newMinute = Minute(Now()) + qWaitTime
newSecond = Second(Now())
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.StatusBar = "Outlook Post Pending for ID: " &
qID & " until " & waitTime
Application.Wait waitTime
Application.StatusBar = ""
End If
With olApt
.Start = qStartDay + qStartTime
.End = qEndDay + qEndTime
.Subject = qTask
.Location = qLocation
.Resources = qResource
.Body = qDesc
.BusyStatus = qShowAs
.ReminderSet = True
.OptionalAttendees = qTo
'// Set Labels with SetApptColorLabel Procedure //
If qLabel = "None" Then xLabel = 0
If qLabel = "Important" Then xLabel = 1
If qLabel = "Business" Then xLabel = 2
If qLabel = "Personal" Then xLabel = 3
If qLabel = "Vacation" Then xLabel = 4
If qLabel = "Must Attend" Then xLabel = 5
If qLabel = "Travel Required" Then xLabel = 6
If qLabel = "Needs Preparation" Then xLabel = 7
If qLabel = "Birthday" Then xLabel = 8
If qLabel = "Anniversary" Then xLabel = 9
If qLabel = "Phone Call" Then xLabel = 10
Call SetApptColorLabel(olApt, xLabel)
.Save
End With
Application.StatusBar = ""
Cells(i, 14) = "Y" '// Set Sent Flag to Y //
Cells(i, 15) = qStartDay + qStartTime & "/" & qEndDay +
qEndTime & "/" & qTask & "/" & qShowAs '// Sets Unique ID //
End If
'// Determine whether or not to transmit to Outlook and
write//
Next

Set olApt = Nothing
Set olApp = Nothing

End Sub