Create Calendar event invite & attach to email

[robgoldstein]

I have a spreadsheet that has a list of parents for my son's soccer team. Every week I input the information for the game their kid is going to play (we have several games a week) and I use a VBA macro to do a mail merge to let the parents know the details of the game. Does anyone know a way to create some way of making it easy for the recipient of the email to add the details to their calendar?
Google does this automatically when I get an email with my itinierary from an airline or an email about restaurant reservation. It would amazing if we could make this happen for these emails as well, but an ICS file would work as well.

Here is the code for my mail merge.

Sub SendWith_SMTP_Gmail_from_sheet()
  'Works On Windows (Not Mac). Mac Users Should Use Zapier Integration
  'Created by Randy Austin www.ExcelForFreelancers.com
  Dim EmailMsg, EmailConf As Object, EmailFields As Variant, sh As Worksheet
  Dim Subj, Mess, LastName, FirstName, Team, GameDate, GameTime, GameLocation, Field, eMail, Attach As String
  Dim ContactRow, LastRow, SentCounter As Long, EmailUsr As String
  '
  EmailUsr = "sctoronto2011boys@gmail.com"
  'Attach = "c:\folder\file name.pdf"  'folder name and file name
  Set sh = Sheets("Roster")
  For ContactRow = 7 To 55
    If sh.Range("I" & ContactRow).Value <> "not scheduled this week" Then
      '
      Set EmailMsg = CreateObject("CDO.Message") 'CDO (Collaboration Data Objects) -Make sure you have the 'CDO For Windows' Library Selected
      Set EmailConf = CreateObject("CDO.Configuration")
      EmailConf.Load -1    ' Set CDO Source Defaults
      Set EmailFields = EmailConf.Fields
      With EmailFields
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = EmailUsr
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "2011soccer"
        .Update
      End With
      '
      Subj = sh.Range("B58").Value 'Email Subject
      Mess = sh.Range("B60").Value 'Email Message
      LastName = sh.Range("D" & ContactRow).Value
      FirstName = sh.Range("C" & ContactRow).Value
      eMail = sh.Range("M" & ContactRow).Value   'In column M you must have the email of each record.
      Team = sh.Range("H" & ContactRow).Value
      GameDate = sh.Range("I" & ContactRow).Value
      GameTime = sh.Range("K" & ContactRow).Text
      GameLocation = sh.Range("J" & ContactRow).Value
      Address = sh.Range("S" & ContactRow).Value
      Map = sh.Range("T" & ContactRow).Value
      Arrive = sh.Range("Q" & ContactRow).Text
      Field = sh.Range("L" & ContactRow).Value
      coach = sh.Range("R" & ContactRow).Value
      
      Subj = Replace(Subj, "#gamedate#", GameDate)
      Mess = Replace(Replace(Mess, "#firstname#", FirstName), "#lastname#", LastName)
      Mess = Replace(Replace(Mess, "#location#", GameLocation), "#team#", Team)
      Mess = Replace(Replace(Mess, "#gamedate#", GameDate), "#gametime#", GameTime)
      Mess = Replace(Mess, "#arrive#", Arrive)
      Mess = Replace(Mess, "#address#", Address)
      Mess = Replace(Mess, "#map#", Map)
      Mess = Replace(Mess, "#field#", Field)
      Mess = Replace(Mess, "#coach#", coach)
      '
      With EmailMsg
        Set .Configuration = EmailConf
        .To = eMail
        .CC = ""
        .BCC = ""
        .From = EmailUsr
        .Subject = Subj
        If Attach <> Empty Then .AddAttachment Attach
        .textBody = Mess
        On Error Resume Next
        .Send
        On Error GoTo 0
      End With
      If Err.Number = 0 Then
        SentCounter = SentCounter + 1
        sh.Range("P" & ContactRow).Value = Now 'Set Send Date & Time
      Else
        sh.Range("P" & ContactRow).Value = "Error : " & Err.Number & " " & Err.Description
      End If
    End If
    'Cleanup
    Set EmailMsg = Nothing
    Set EmailConf = Nothing
    Set EmailFields = Nothing
  Next ContactRow
  MsgBox SentCounter & " Emails have been sent"
End Sub

any help would be appreciated.

 

[Trevor_S]

Producing an ICS file is possible. Not so sure about how the automatic addition of items to calendars would work though. I would imagine that it must be at least partially dependent on the functionality of the email and calendar apps used by the recipient?

So for the ICS file production, you need code something like this before you start the email. You can then amend your email code to attach the file generated.

Open "C:/Documents/Test.ics" For Output As #1 'This is the file path/name for the ICS file
Print #1, "BEGIN:VCALENDAR"
Print #1, "VERSION:2.0"
' Similar code for remainder of ICS file
Print #1, "END:VCALENDAR"
Close #1

To get the code for the ICS file, would suggest generating a file by exporting an item from your calendar and viewing it in notepad. Alternatively you can find examples on the internet (e.g. there's an example on the ICS Wikipedia page), but I wouldn't know which lines in these are strictly necessary, and which are optional. The Print #1, lines are just text strings, so you can build them from data in your spreadsheet, in the same way as you've got data for the email body. On the date/time lines, the format is YYYYMMDD and HHMMSS, with the two elements separated by a T and the string ending witha Z. Probably worth experimenting, then importing to your calendar to see if they appear as you would want.