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

 

[Paul Alford]

Just tried to run the code and I get an error: An object could not be found. It's relating to that code with the weird quotes.

Object hierarchies take some getting your head around

 

[RoryA]

Try breaking it up into stages:

    Dim olApp As Outlook.Application
    Dim olApt As AppointmentItem
    Dim olFldr As Outlook.MAPIFolder
    Dim objNS as Outlook.Namespace
    Set olApp = New Outlook.Application
   Set objNS = olApp.GetNamespace("MAPI")
    Set olFldr = objNS.Folders("Personal Folders")
   Set olFldr = olFldr.Folders("Buyer Engagement")
    Set olApt = olFldr.Items.Add

and see if/where it breaks.