Create Outlook Appointment from Excel

[Paul Alford]

Hi,

I've used some code from another thread on the forum to create an Outlook Appointment and email this as an attached .ics file from an Excel spreadsheet. Everything seems to work fine. The email is sent and the attachment when double clicked opens in Outlook with all the correct information, but when the recipient clicks 'Save and Close' it doesn't save in their calaendar. I've been trawling this and other forums trying to find a solution, but I'm at a loss.

Any help would be greatly appreciated. The VBA code is below. I'm using Excel 2007.

Cheers
Paul

Sub SendEmail()
  'Uses early binding
  'Requires a reference to the Outlook Object Library
  Dim OutlookApp As Outlook.Application
  Dim MItem As Outlook.MailItem
  Dim olAppointment As Outlook.AppointmentItem
  
  Dim cell As Range
  Dim Subj As String
  Dim EmailAddr As String
  Dim Fname As String
  Dim Lname As String
  Dim Tel As String
  Dim Adate As Date
  Dim Atime As String
  Dim SupportFirstName As String
  Dim Score As String
  Dim Msg As String
  Dim Msg2 As String
  Dim CustomerEmail As String
  Dim icsdate As String
  Dim icstime As String
      
  'Create Outlook object
  Set OutlookApp = New Outlook.Application
  
  'Loop through the rows
  For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "*@*" Then
      'Get the data
      Subj = "Buyer Engagement Appointment"
      Fname = cell.Offset(0, -3).Value
      Lname = cell.Offset(0, -2).Value
      CustomerEmail = cell.Offset(0, -1).Value
      EmailAddr = cell.Value
      Tel = cell.Offset(0, 1).Value
      Score = cell.Offset(0, 2).Value
      Adate = cell.Offset(0, 3).Value
      Atime = cell.Offset(0, 4).Value
      SupportFirstName = cell.Offset(0, 5).Value
      icsdate = cell.Offset(0, 7).Value
      icstime = cell.Offset(0, 8).Value
      FileLocation = "C:\ApptFiles\OutlookAppointment.ics"
      
     'Compose message
      Msg = "Dear " & SupportFirstName & vbCrLf & vbCrLf
      Msg = Msg & "Please call:" & vbCrLf & vbCrLf
      Msg = Msg & "Name: " & Fname & " " & Lname & " on " & Adate & "." & vbCrLf
      Msg = Msg & "Telephone: " & Tel & vbCrLf
      Msg = Msg & "Email: " & CustomerEmail & vbCrLf
      Msg = Msg & "Score: " & Score & vbCrLf & vbCrLf
      Msg = Msg & "If you have any queries please contact John Doe either by email john.doe@acme.co.uk or telephone 0207 450 2111" & vbCrLf & vbCrLf
      Msg = Msg & "Kind Regards" & vbCrLf
      Msg = Msg & "Buyer Engagement Recruitment Team"
    
      'Compose appointment subject
      Msg2 = "Buyer Engagement Appointment with " & Fname & " " & Lname
      'Create Mail Item and send it
      
    Dim olApp As Outlook.Application
    Dim olApt As AppointmentItem
    
    Set olApp = New Outlook.Application
    Set olApt = olApp.CreateItem(olAppointmentItem)
    Msg2 = "Buyer Engagement Appointment with " & Fname & " " & Lname
    
    With olApt
        .Start = Adate
        .End = .Start + TimeValue("00:30:00")
        .Subject = Msg2
        .Location = " "
        .Body = Msg
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = 2880
        .ReminderSet = True
        '.Display
        
        'Save the iCalendar file in a known folder
        .SaveAs "C:\ApptFiles\OutlookAppointment.ics"
        
        'Use Close to retain the new appointment within the Outlook Calendar, or Delete to delete it.
        'Both options keep the just-created .ics file
        
        '.Close False
        .Delete
    
    End With

      Set MItem = OutlookApp.CreateItem(olMailItem)
      With MItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Msg
        .Attachments.Add (FileLocation)
        '.Send
        .Save 'to Drafts folder
      End With
      
    End If
  Next
  Set OutlookApp = Nothing
  Set olApt = Nothing
  Set olApp = Nothing

End Sub

 

[RoryA]

I can't see anything wrong with the code at first glance, and the fact that the item is mailed and can be opened would back that up. Are you using the same version of Outlook as the recipient?

 

[Paul Alford]

Hi Rory,

Thanks for the swift reply. Yes the same Outlook version is running on the recipients machine too. Also, I save it as a Draft at the moment and even when I try to save in my own calendar it doesn't appear. Puzzling...

One thing I have noticed is that the resultant .ics file that's created, when opened in Notepad isn't a text file, which I expected. It looks like it is saved in an encrypted format. Should that be the case?

Cheers
Paul

 

[RoryA]

What happens if you change the saveas line to this:

.SaveAs "C:\ApptFiles\OutlookAppointment.ics", olICal

 

[Paul Alford]

Ah Ha! You're a star!!!!! It works.

Out of interest, what does that statement actually do?

Thank you so much, I really appreciate your help.

 

[RoryA]

It specifies that you want to save it as an iCalendar file format.

 

[Paul Alford]

Doh, so obvious now you've said that.

Here's another query I can't seem to solve. I'm trying to have the appointments drop into another calendar other than the users default calendar and I've used this line of code:

Set olFldr = olApp.GetNamespace(”MAPI”).Folders(”Personal Folders”).Folders(”Buyer Engagement”)

Before this code I have the following Dim and Set statements.

Dim olFldr As Outlook.MAPIFolder
Set olApt = olFldr.Items.Add

The problem I'm up against is a syntax error that reports the need for a List Seperator or ) on that first line of code above.

For the life of me I can't see the error.

Thanks in advance.
Paul

 

[RoryA]

Your quotation marks look weird - does this version work?

Set olFldr = olApp.GetNamespace("MAPI").Folders("Personal Folders").Folders("Buyer Engagement")

Note you also seem to be trying to use the olFldr before you Set it, based on what you said.

 

[Paul Alford]

To the rescue again! Many thanks Rory, it was the quotes.

I'm still going up a very steep learning curve with VB.

In response to your note, here is the code you helped with yesterday with the new lines of code to try and write to a different calendar. The lines I have added are in blue, and red code is what I have commented out. I assumed that I couldn't use CreateItem and Items.Add together?

EDIT: Just tried to run the code and I het an error: Object no found. It relates to that code with the weird quotes.

Sub SendEmail()
  'Uses early binding
  'Requires a reference to the Outlook Object Library
  Dim OutlookApp As Outlook.Application
  Dim MItem As Outlook.MailItem
  Dim olAppointment As Outlook.AppointmentItem
  
  Dim cell As Range
  Dim Subj As String
  Dim EmailAddr As String
  Dim Fname As String
  Dim Lname As String
  Dim Tel As String
  Dim Adate As Date
  Dim SupportFirstName As String
  Dim Score As String
  Dim Msg As String
  Dim Msg2 As String
  Dim CustomerEmail As String
      
  'Create Outlook object
  Set OutlookApp = New Outlook.Application
  
  'Loop through the rows
  For Each cell In Columns("F").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "*@*" Then
      'Get the data
      Subj = "Buyer Engagement Appointment"
      Fname = cell.Offset(0, -5).Value
      Lname = cell.Offset(0, -4).Value
      CustomerEmail = cell.Offset(0, -3).Value
      EmailAddr = cell.Value
      Tel = cell.Offset(0, -2).Value
      Score = cell.Offset(0, -1).Value
      Adate = cell.Offset(0, 1).Value
      SupportFirstName = cell.Offset(0, 2).Value
      FileLocation = "C:\ApptFiles\OutlookAppointment.ics"
      
     'Compose message
      Msg = "Dear " & SupportFirstName & vbCrLf & vbCrLf
      Msg = Msg & "Please call:" & vbCrLf & vbCrLf
      Msg = Msg & "Name: " & Fname & " " & Lname & " on " & Adate & "." & vbCrLf
      Msg = Msg & "Telephone: " & Tel & vbCrLf
      Msg = Msg & "Email: " & CustomerEmail & vbCrLf
      Msg = Msg & "Score: " & Score & vbCrLf & vbCrLf
      Msg = Msg & "If you have any queries please contact John Doe either by email john.doe@acme.co.uk or telephone 0207 450 2111" & vbCrLf & vbCrLf
      Msg = Msg & "Kind Regards" & vbCrLf
      Msg = Msg & "Buyer Engagement Recruitment Team"
    
      
    Dim olApp As Outlook.Application
    Dim olApt As AppointmentItem
    [COLOR=Lime][COLOR=RoyalBlue]Dim olFldr As Outlook.MAPIFolder[/COLOR]
[/COLOR]
    Set olApp = New Outlook.Application
   [COLOR=Red] 'Set olApt = olApp.CreateItem(olAppointmentItem)[/COLOR]
    [COLOR=RoyalBlue]Set olFldr = olApp.GetNamespace("MAPI").Folders("Personal Folders").Folders("Buyer Engagement")
    Set olApt = olFldr.Items.Add[/COLOR]
    
     'Compose appointment subject
      Msg2 = "Buyer Engagement Appointment with " & Fname & " " & Lname
    
    With olApt
        .Start = Adate
        .End = .Start + TimeValue("00:30:00")
        .Subject = Msg2
        .Location = " "
        .Body = Msg
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = 2880
        .ReminderSet = True
        '.Display
        
        'Save the iCalendar file in a known folder
        .SaveAs "C:\ApptFiles\OutlookAppointment.ics", olICal
        
        'Use Close to retain the new appointment within the Outlook Calendar, or Delete to delete it.
        'Both options keep the just-created .ics file
        
        '.Close False
        .Delete
    
    End With
    
     'Create Mail Item and send it
      Set MItem = OutlookApp.CreateItem(olMailItem)
      With MItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Msg
        .Attachments.Add (FileLocation)
        '.Send
        .Save 'to Drafts folder
      End With
      
    End If
  Next
  Set OutlookApp = Nothing
  Set olApt = Nothing
  Set olApp = Nothing

End Sub

 

[RoryA]

That looks fine. I'd use Items.Add for that - it's easier.