Excel 2007 - Create Outlook 2007 Appointment + Avoid double entry creation + Update

[Legacy 223018]

Hi All,

I'm new to this forum and to VBA. Still I have a rather tricky question to ask.
I have an Excel 2007 work sheet with deadlines for action items. Formulas behind dates, each one of which is in a different column, ("launching date", "foreseen end date", "postponed date" and "closure date") determine the action's status ("not launched", "in progress", "delayed", "postponed", "closed").
I want to create in my Outlook 2007 calendar appointments based on "foreseen end date" and (if applicable) on "postponed date". I managed to do that by nicking some code from the net and adjusting it to my needs. I also managed the second part: avoiding the creation of double entries if I run the macro more than once (which I'll surely do). What I don't manage yet is that an appointment is updated when I run the macro: If I change the due date, i.e. if I give the action a "postponed date" I would like the macro to update the appointment to that date.
I'd be very grateful for any help I can get to understand what I'm doing wrong! Thanks a lot in advance!!
Code below...

Option Explicit


' requires a reference to the Microsoft Outlook x.0 Object Library
Sub UpdateOL_Appts()


Dim OL As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim olApptSearch As Outlook.AppointmentItem
Dim colItems As Outlook.Items
Dim r As Long, LastRow As Long
Dim sSubject As String, sBody As String, sSearch As String
Dim dStart1 As Date, dStart2 As Date
Dim bOLOpen As Boolean
Dim dDuration As Double


    On Error Resume Next
    Set OL = GetObject("", "Outlook.Application")
    bOLOpen = True
    If OL Is Nothing Then
        Set OL = CreateObject("Outlook.Application")
        bOLOpen = False
    End If
    Set NS = OL.GetNamespace("MAPI")
    Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items
         
    r = 10
    
    While Cells(r, 11) <> "" Or Cells(r, 11) <> "Not launched" Or Cells(r, 11) <> "closed"
        
        sSubject = Cells(r, 3).Value
        sBody = Cells(r, 5).Value
        dStart1 = Cells(r, 6).Value + TimeValue("10:00:00")
        dStart2 = Cells(r, 7).Value + TimeValue("10:00:00")
        dDuration = 60
      
        sSearch = "[Subject] = " & sQuote(sSubject)
        Set olApptSearch = colItems.Find(sSearch)
        
        If Not olAppItem Is Nothing Then
          If Cells(r, 7) <> "" Then
               olAppItem.Start = dStart2
               olAppItem.Duration = dDuration
               olAppItem.Subject = sSubject
               olAppItem.Location = ""
               olAppItem.Body = "This is a rescheduled action item. Get an update on this action item from " & sBody
               olAppItem.ReminderSet = True
               olAppItem.ReminderMinutesBeforeStart = 30
               olAppItem.BusyStatus = olFree
               olAppItem.RequiredAttendees = ""
               olAppItem.Categories = "Product Policy Action"
               olAppItem.Close olSave
          End If
        End If
          
        If olApptSearch Is Nothing Then
            If Cells(r, 11) = "postponed" Then
                Set olAppItem = OL.CreateItem(olAppointmentItem)
                    olAppItem.Start = dStart2
                    olAppItem.Duration = dDuration
                    olAppItem.Subject = sSubject
                    olAppItem.Location = ""
                    olAppItem.Body = "Get an update on this action item from " & sBody
                    olAppItem.ReminderSet = True
                    olAppItem.ReminderMinutesBeforeStart = 30
                    olAppItem.BusyStatus = olFree
                    olAppItem.RequiredAttendees = ""
                    olAppItem.Categories = "Product Policy Action"
                    olAppItem.Close olSave
                            
            ElseIf Cells(r, 11) = "in progress" Or Cells(r, 11) = "delayed" Then
                Set olAppItem = OL.CreateItem(olAppointmentItem)
                    olAppItem.Start = dStart1
                    olAppItem.Duration = dDuration
                    olAppItem.Subject = sSubject
                    olAppItem.Location = ""
                    olAppItem.Body = "Get an update on this action item from " & sBody
                    olAppItem.ReminderSet = True
                    olAppItem.ReminderMinutesBeforeStart = 30
                    olAppItem.BusyStatus = olFree
                    olAppItem.RequiredAttendees = ""
                    olAppItem.Categories = "Product Policy Action"
                    olAppItem.Close olSave
            End If
       End If
    
    r = r + 1
    
    If bOLOpen = False Then OL.Quit
    
    Wend
       
End Sub
Function sQuote(sTextToQuote)
    sQuote = """" & sTextToQuote & """"
End Function

NB: dStart1 = foreseen end date; dStart2 = postponed date.

 

[Legacy 223018]

I've managed to get the macro running. The code I posted initially caused problems but I corrected the error. So, There you go for a code that creates Outlook appointments in case you have two sorts of due dates.
One big question remains though: I still need help with the deletion / update of an appointment created earlier. So far, once it has been created, I have to delete it manually. If I run the macro after the manual deletion, an appointment will be created with the updated date. But as for the macro: no matter how I tweak the code, it won't delete it / update the appointment.
Any ideas?

' requires a reference to the Microsoft Outlook x.0 Object Library
Sub UpdateOL_Appts()


Dim OL As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim olAppSearch As Outlook.AppointmentItem
Dim colItems As Outlook.Items
Dim r As Long, LastRow As Long
Dim sSubject As String, sBody As String, sSearch As String
Dim dStart1 As Date, dStart2 As Date
Dim bOLOpen As Boolean
Dim dDuration As Double






    On Error Resume Next
    Set OL = GetObject("", "Outlook.Application")
    bOLOpen = True
    If OL Is Nothing Then
        Set OL = CreateObject("Outlook.Application")
        bOLOpen = False
    End If
    Set NS = OL.GetNamespace("MAPI")
    Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items
         
    r = 10
    Do Until Cells(r, 11).Value = ""
    
        If Cells(r, 11) = "Not launched" Or Cells(r, 11) = "closed" Then GoTo NextRow
        
        sSubject = Cells(r, 3).Value
        sBody = Cells(r, 5).Value
        dStart1 = Cells(r, 6).Value + TimeValue("10:00:00")
        dStart2 = Cells(r, 7).Value + TimeValue("10:00:00")
        dDuration = 60
      
        sSearch = "[Subject] = " & sQuote(sSubject)
        Set olAppSearch = colItems.Find(sSearch)
        
        If olAppSearch Is Nothing Then
            If Cells(r, 11) = "postponed" Then
                Set olAppItem = OL.CreateItem(olAppointmentItem)
                    olAppItem.Start = dStart2
                    olAppItem.Duration = dDuration
                    olAppItem.Subject = sSubject
                    olAppItem.Location = ""
                    olAppItem.Body = "This is a rescheduled action item. Get an update on this action item from " & sBody
                    olAppItem.ReminderSet = True
                    olAppItem.ReminderMinutesBeforeStart = 1440
                    olAppItem.BusyStatus = olFree
                    olAppItem.RequiredAttendees = ""
                    olAppItem.Categories = "Product Policy Action"
                    olAppItem.Close olSave
                            
            ElseIf Cells(r, 11) = "in progress" Or Cells(r, 11) = "delayed" Then
                Set olAppItem = OL.CreateItem(olAppointmentItem)
                    olAppItem.Start = dStart1
                    olAppItem.Duration = dDuration
                    olAppItem.Subject = sSubject
                    olAppItem.Location = ""
                    olAppItem.Body = "Get an update on this action item from " & sBody
                    olAppItem.ReminderSet = True
                    olAppItem.ReminderMinutesBeforeStart = 1440
                    olAppItem.BusyStatus = olFree
                    olAppItem.RequiredAttendees = ""
                    olAppItem.Categories = "Product Policy Action"
                    olAppItem.Close olSave
            End If
       
       Else: olAppItem.Delete
       End If
       
NextRow:
    r = r + 1
    
    Loop
    
    If bOLOpen = False Then OL.Quit
    
End Sub

Function sQuote(sTextToQuote)
    sQuote = """" & sTextToQuote & """"
End Function