Reply to thread

Message: [QUOTE="somethinglikeant, post: 4875320"] 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 [/QUOTE]

Verification