Create Outlook reminders based on date entered in specific column

[Ellie3457]

Hello all,

I would like to create Outlook reminders based on task due dates in a specific column (in some instances there will be no date).

I managed to create a code that works based on pieces of code found in other threads and my own. The code works perfectly and does what I want it to do but it relies on the entry id and my only issue is that I don't find the entryid output in column D very elegant and instead of having the entryid value entered in column D, I would like to only have the words "created" after a reminder is created. The ideal code would create a reminder if there is a date present in column C and if the corresponding value in column D is blank (to prevent duplicates). The macro will be run multiple times since the file will constantly be updated with new task and dates.

Sub New_Attempt()


Dim rng As Range
Dim Dtrng As Range
Dim strEntryID As String
Dim olkAppt As Object
Static olkApp As Object
Const olAppointmentItem As Integer = 1
Dim LastRow As Long
Application.EnableEvents = False

LastRow = Cells(Rows.Count, "C").End(xlUp).Row
Set rng = Range("C2:C" & LastRow)
If rng Is Nothing Then Exit Sub
If olkApp Is Nothing Then Set olkApp = CreateObject("outlook.application")

For Each Dtrng In rng
 If Dtrng.Value <> "" Then
        Select Case Dtrng.Column
            Case Columns("C").Column
                strEntryID = Range("D" & Dtrng.Row)
            Case Else
                Application.EnableEvents = True
                Exit Sub
        End Select
            If strEntryID <> "" Then
            On Error Resume Next
            Set olkAppt = olkApp.session.getitemfromid(strEntryID)
            On Error GoTo 0
        End If
        If olkAppt Is Nothing Then Set olkAppt = olkApp.CreateItem(olAppointmentItem)
        With olkAppt
            .Start = Range("C" & Dtrng.Row)
            .Duration = 30
            .Subject = "Complete " & Range("A" & Dtrng.Row)
            .Body = "Complete " & Range("A" & Dtrng.Row) & " Start date: " & Range("B" & Dtrng.Row)
            .reminderminutesbeforestart = 15
            .BusyStatus = 5
            .reminderset = True
            .Save
            
            Select Case Dtrng.Column
                Case Columns("C").Column
                    Range("D" & Dtrng.Row) = .entryid

            End Select
        End With
    End If
    Set olkAppt = Nothing
Next

Application.EnableEvents = True

MsgBox "Reminder(s) created"

End Sub

Thanks for your time and help!

Regards,

Ellie

 

[John_w]

Each Entry Id uniquely identifies an appointment. If you don't want to use the Entry Id to find an existing appointment, how will you find existing appointments?

 

[Ellie3457]

Hi! Thanks a lot for taking the time to respond.

So to clarify, I was trying to simplify the above and was thinking of a code that would create an outlook appointment for each (row) that has a date entered in column C and enter the text "appointment created" in the adjacent cell of column D for each row where an appointment was created . However, I want to make sure that no appointments are created for rows that do not have a date in column C and rows that have a date but where the adjacent cell in column D contains the text "appointment created".

This way, when I add more data, no appointment will be created if there is no date or if an appointment has already been created for that row. The "appointment created" part is to be able to identify the tasks for which appointments have already been created and also to avoid duplication when running the macro multiple times.

I don't really need to find existing appointments based on the entry id. I just want to create or not create appointments based on the above.

I hope this makes sense.

Thanks for your time and help, I appreciate it.

Ellie

 

[John_w]

Try this macro:

Option Explicit

Public Sub Create_Outlook_Appointments()

    Dim outApp As Outlook.Application
    Dim outNamespace As Outlook.Namespace
    Dim outCalendarFolder As Outlook.MAPIFolder
    Dim outAppointment As Outlook.AppointmentItem
    Dim OutlookCreated As Boolean
    Dim ws As Worksheet
    Dim r As Long
    
    OutlookCreated = False
    On Error Resume Next
    Set outApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If outApp Is Nothing Then
        Set outApp = New Outlook.Application
        OutlookCreated = True
    End If
    
    Set outNamespace = outApp.GetNamespace("MAPI")
    Set outCalendarFolder = outNamespace.GetDefaultFolder(olFolderCalendar)
    outNamespace.Logon
    
    Set ws = ActiveSheet
    
    r = 2
    While ws.Cells(r, "A").Value <> ""
    
        'Create this appointment if column C is a date and D doesn't contain "Appointment created"
        
        If IsDate(ws.Cells(r, "C").Value) And InStr(1, ws.Cells(r, "D").Value, "Appointment created", vbTextCompare) = 0 Then

            Set outAppointment = outApp.CreateItem(olAppointmentItem)
            With outAppointment
                .Start = ws.Cells(r, "C").Value
                .Duration = 30
                .Subject = "Complete " & ws.Cells(r, "A").Value
                .Body = "Complete " & ws.Cells(r, "A").Value & vbCrLf & _
                        "Start date: " & ws.Cells(r, "B").Value & vbCrLf & _
                        "Due date: " & ws.Cells(r, "C").Value
                .ReminderMinutesBeforeStart = 18 * 60 '18 hours
                .ReminderSet = True
                .Close olSave
            End With
        
            ws.Cells(r, "D").Value = "Appointment created " & Now
        End If
        
        r = r + 1
    Wend
    
    outNamespace.Logoff
    If OutlookCreated Then outApp.Quit
    Set outCalendarFolder = Nothing
    Set outNamespace = Nothing
    Set outApp = Nothing

End Sub

 

[Ellie3457]

Thanks a lot for your time and help. This works perfectly and I learned a few things

Just FYI: I was first getting the error " User-Defined Type Not Defined" when trying to run the code.
So I had to go to Tools > References and "tick" Microsoft Outlook 16.0 Object Library. Just mentioning this here in case someone else looks at this thread.