Excel to Outlook Appointment

[dontasciime]

Hi Everyone,

I am new to this forum and I am really stuck! I have a macro in Excel that automatically emails specified users when any changes have been made to the worksheet.

Now they are asking me to create macro that generates an Outlook Appointment based on the due date in the same Excel sheet. I know that it can be done, but I am not sure how to!

These are the columns where the info is I need to include in the appointment. Ideally, they'd like to see the Subject as Column A, Column C and Column D.

Column A - Number
Column C - Item
Column D - Description
Column N - Due Date

Would anyone be able to help me or tell me where I can find a reference on how to write this code?

Thanks,
d*

 

[John_w]

Try something like this. Put this code in a standard module.

Option Explicit

'Requires reference to Microsoft Outlook Object Library.  Set this in Tools - References in VB Editor.

Public olApp As Outlook.Application

Private Sub Test()

    Dim row As Long
    Dim subject As String
    
    With ActiveSheet
        For row = 2 To 5
            subject = .Cells(row, "A").Value & " " & .Cells(row, "C").Value & " " & .Cells(row, "D").Value
            Create_Outlook_Appointment subject, .Cells(row, "N").Value
        Next
    End With
        
End Sub

Public Sub Create_Outlook_Appointment(subject As String, dueDateTime As Date)

    Dim olApt As Outlook.AppointmentItem
    
    If olApp Is Nothing Then Set olApp = New Outlook.Application
    Set olApt = olApp.CreateItem(olAppointmentItem)

    With olApt
        .Start = dueDateTime
        .AllDayEvent = True
        .subject = subject
        .ReminderSet = False
        .Close olSave
    End With

End Sub

 

[will31]

dontasciime, could you post or PM message me the code to send an email when the file is ammended That sounds pretty cool

 

[dontasciime]

Thanks John w! That works really well! I have one question though. New records are always being added to sheet. Is there any way that I can specify which rows are being exported or is there a way to ensure there the user does not end up with duplicated records (keeping in mind the due date can change so any kind of lookup would have to be based off of column A).

 

[John_w]

I don't understand you - is your question related to your original post, or a different requirement? My code doesn't export any records. If, by duplicated records you mean duplicated appointments, try this refinement, which ensures that duplicated appointments aren't created. Maybe you could call Update_Appointment() from your own worksheet change macro.

Option Explicit

'Requires reference to Microsoft Outlook Object Library

Public olApp As Outlook.Application
Public olNamespace As Outlook.Namespace
Public olCalendarFolder As Outlook.MAPIFolder


Private Sub Test()

    Dim row As Long
    Dim subject As String
    
    With ActiveSheet
        For row = 2 To 6
            subject = .Cells(row, "A").Value & " " & .Cells(row, "C").Value & " " & .Cells(row, "D").Value
            Update_Appointment subject, .Cells(row, "N").Value
        Next
    End With
        
End Sub

Public Sub Update_Appointment(subject As String, dueDateTime As Date)

    Dim olApt As Outlook.AppointmentItem
    
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
        Set olNamespace = olApp.GetNamespace("MAPI")
        Set olCalendarFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
        olNamespace.Logon
    End If
    
    Set olApt = Get_Appointment(subject)
    If Not olApt Is Nothing Then
        If olApt.Start <> dueDateTime Then
            
            'Appointment already exists and the due date has changed so update it
            
            olApt.Start = dueDateTime
            olApt.Save
        End If
    Else
    
        'Create new appointment
    
        Set olApt = olApp.CreateItem(olAppointmentItem)
        With olApt
            .Start = dueDateTime
            .AllDayEvent = True
            .subject = subject
            .ReminderSet = False
            .Close olSave
        End With
    End If
        
End Sub
        
Private Function Get_Appointment(subject As String) As Outlook.AppointmentItem

    Dim olCalendarItems As Outlook.Items
    Dim subjectFilter As String
    
    'Get calendar items with the specified subject
        
    subjectFilter = "[Subject] = '" & subject & "'"
    Set olCalendarItems = olCalendarFolder.Items.Restrict(subjectFilter)
    
    If olCalendarItems.Count > 0 Then
        Set Get_Appointment = olCalendarItems.Item(1)
    Else
        Set Get_Appointment = Nothing
    End If
    
End Function

 

[dontasciime]

Hi John_w,

Thanks again for the code. That's what I was looking for.

I'm having a problem though, when I run the code i am getting a compile error - variable not defined for the olCalendarFolder in Get_Appointment function:

Set olCalendarItems = olCalendarFolder.Items.Restrict(subjectFilter)

When I add Dim olCalendarFolder As Outlook.MAPIFolder, I get a run-time error '91' - object variable or with block variable not set.

 

[John_w]

It works for me. Make sure you have:

Public olCalendarFolder As Outlook.MAPIFolder

as posted, and that:

Set olCalendarFolder = olNamespace.GetDefaultFolder(olFolderCalendar)

is being executed (at least once per session). Try stepping through the code line by line in the VB Editor.

 

[dontasciime]

Ok, it runs now, but I'm still having trouble. Below is exactly what I have in Module 1:

Option Explicit

Public olApp As Outlook.Application
Public olNamespace As Outlook.Namespace
Public olCalendarFolder As Outlook.MAPIFolder

Private Sub InsertOutlookAppointment()

Dim row As Long
Dim subject As String

With ActiveSheet
For row = 2 To 48
subject = .Cells(row, "A").Value & " -- " & .Cells(row, "C").Value & " -- " & .Cells(row, "D").Value
Update_Appointment subject, .Cells(row, "N").Value
Next
End With

End Sub

Public Sub Update_Appointment(subject As String, dueDateTime As Date)

Dim olApt As Outlook.AppointmentItem

If olApp Is Nothing Then
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olCalendarFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
olNamespace.Logon
End If

Set olApt = Get_Appointment(subject)
If Not olApt Is Nothing Then
If olApt.Start <> dueDateTime Then

'Appointment already exists and the due date has changed so update it
olApt.Start = dueDateTime
olApt.Save
End If
Else

'Create new appointment
Set olApt = olApp.CreateItem(olAppointmentItem)
With olApt
.Start = dueDateTime
.AllDayEvent = True
.subject = subject
.ReminderSet = False
.Close olSave
End With
End If

End Sub
Private Function Get_Appointment(subject As String) As Outlook.AppointmentItem

Dim olCalendarItems As Outlook.Items
Dim subjectfilter As String

'Get calendar items with the specified subject
subjectfilter = "[Subject] = '" & subject & "'"
On Error Resume Next
Set olCalendarItems = olCalendarFolder.Items.Restrict(subjectfilter)

If olCalendarItems.Count > 0 Then
Set GetAppointment = olCalendarItems.Item(1)
Else
Set GetAppointment = Nothing
End If

End Function

Then, in "This Workbook" I have:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If MsgBox("Select yes to allow Excel to create/update Outlook Appointment for all dockets.", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
Else
Run "Update_Appointment"
End If
End Sub

I get Argument not optional (Error 449). I tried to use Call Update_Appointment() but first of, it removes the () part of it after I type it and secondly it gives me a compile error: Argument not optional.

Also, in the InsertOutlookAppointment, for the row = 2 to 48 part, is there a way to just have it look at all of the rows with data in them? Otherwise, every time I add a line I have to edit the code.

Private Sub InsertOutlookAppointment()

Dim row As Long
Dim subject As String

With ActiveSheet
For row = 2 To 48


I will admit I'm lost and probably in way above my head! Sorry to have to keep bothering you about this!

 

[John_w]

First, you should put VBA code between [ code] and [/ code] tags without the spaces to preserve the indentation.

Then, in "This Workbook" I have:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If MsgBox("Select yes to allow Excel to create/update Outlook Appointment for all dockets.", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
Else
Run "Update_Appointment"
End If
End Sub

I get Argument not optional (Error 449). I tried to use Call Update_Appointment() but first of, it removes the () part of it after I type it and secondly it gives me a compile error: Argument not optional.

Shouldn't you be calling your InsertOutlookAppointment instead?

Try this (I have given the routine which updates/creates all the Outlook appointments a more appropriate name):

ThisWorkbook

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If MsgBox("Select yes to allow Excel to create/update Outlook Appointment for all dockets.", vbYesNo + vbQuestion) = vbYes Then
        Update_All_Outlook_Appointments
    End If
End Sub

Module1

Option Explicit

'Requires reference to Microsoft Outlook Object Library

Public olApp As Outlook.Application
Public olNamespace As Outlook.Namespace
Public olCalendarFolder As Outlook.MAPIFolder


Private Sub Test()

    Dim row As Long
    Dim subject As String
    
    With ActiveSheet
        For row = 2 To 6
            subject = .Cells(row, "A").Value & " " & .Cells(row, "C").Value & " " & .Cells(row, "D").Value
            Update_Appointment subject, .Cells(row, "N").Value
        Next
    End With
        
End Sub


Public Sub Update_All_Outlook_Appointments()

    Dim row As Long
    Dim subject As String
    Dim lastRow As Long
    
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).row
        For row = 2 To lastRow
            subject = .Cells(row, "A").Value & " -- " & .Cells(row, "C").Value & " -- " & .Cells(row, "D").Value
            Update_Appointment subject, .Cells(row, "N").Value
        Next
    End With

End Sub

Public Sub Update_Appointment(subject As String, dueDateTime As Date)

    Dim olApt As Outlook.AppointmentItem
    
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
        Set olNamespace = olApp.GetNamespace("MAPI")
        Set olCalendarFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
        olNamespace.Logon
    End If
    
    Set olApt = Get_Appointment(subject)
    If Not olApt Is Nothing Then
        If olApt.Start <> dueDateTime Then
            
            'Appointment already exists and the due date has changed so update it
            
            olApt.Start = dueDateTime
            olApt.Save
        End If
    Else
    
        'Create new appointment
    
        Set olApt = olApp.CreateItem(olAppointmentItem)
        With olApt
            .Start = dueDateTime
            .AllDayEvent = True
            .subject = subject
            .ReminderSet = False
            .Close olSave
        End With
    End If
        
End Sub
        
Private Function Get_Appointment(subject As String) As Outlook.AppointmentItem

    Dim olCalendarItems As Outlook.Items
    Dim subjectFilter As String
    
    'Get calendar items with the specified subject
        
    subjectFilter = "[Subject] = '" & subject & "'"
    Set olCalendarItems = olCalendarFolder.Items.Restrict(subjectFilter)
    
    If olCalendarItems.Count > 0 Then
        Set Get_Appointment = olCalendarItems.Item(1)
    Else
        Set Get_Appointment = Nothing
    End If
    
End Function

 

[End_User]

Tried to use this too and got duplicate entries?