Send Multiple Meeting Invites using outlook from excel

Hi All,

I have got the below macro which loops through the rows in a sheet and schedules appointments in outlook in as per my requirement but I have following issues with the below macro.

1) I want to know how I can also add the Label along with the .Body, Subject, Location etc.. Label is usually used to define colours for appointments for e.g. Important, Business, Personal etc.

2) I want to know how I can insert / copy a long text with some URL/links in it and a data table on my appointment body. I have all data in a excel sheet in a name range. .i.e. "Mailbodytext". This range is quit big .i.e. from Cell A1:X55. It's properly formatted. I want to copy this range along with formatting without gridlines on my appointment body.

Code:

---

Option Explicit

' requires a reference to the Microsoft Outlook x.0 Object Library
Sub RegisterAppointmentList()
' adds a list of appontments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
'Dim myrange As String
'myrange = Range("myrange").Value
    DeleteTestAppointments ' deletes previous test appointments
    On Error Resume Next
    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    r = 10 ' first row with appointment data in the active worksheet
    While Len(Cells(r, 1).Formula) > 0
        Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
        With olAppItem
            ' set default appointment values
            .Start = Now
            .End = Now
            .Subject = "No subject"
            .Location = ""
            .Body = ""
            .ReminderSet = True
            .BusyStatus = olFree
            .RequiredAttendees = ""
           
           
            ' read appointment values from the worksheet
            On Error Resume Next
            .Start = Cells(r, 1).Value + Cells(r, 2).Value
            .End = Cells(r, 8).Value + Cells(r, 3).Value
            .Subject = Cells(r, 4).Value
            .Location = Cells(r, 5).Value
            .Body = varBody
            .ReminderSet = Cells(r, 7).Value
            .BusyStatus = Cells(r, 9).Value
            .RequiredAttendees = Cells(r, 10).Value
            .Categories = "TestAppointment" ' add this to be able to delete the testappointments
            On Error GoTo 0
            .Save ' saves the new appointment to the default folder
        End With
        r = r + 1
    Wend
    Set olAppItem = Nothing
    Set olApp = Nothing
End Sub

Sub DeleteTestAppointments()
' deletes all testappointments in Outlook
Dim olApp As Outlook.Application
Dim OLF As Outlook.MAPIFolder
Dim r As Long, dCount As Long
    On Error Resume Next
    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = GetObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    Set OLF = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    dCount = 0
    For r = OLF.Items.Count To 1 Step -1
        If TypeName(OLF.Items(r)) = "AppointmentItem" Then
            If InStr(1, OLF.Items(r).Categories, "TestAppointment", vbTextCompare) = 1 Then
                OLF.Items(r).Delete
                dCount = dCount + 1
            End If
        End If
    Next r
    Set olApp = Nothing
    Set OLF = Nothing
End Sub

---

I have attached my macro file for your reference.

Thanks a lot for your help in advance.:)

Hi All,

Did anyone get the chance to look at the above post.

Thanks a lot for your help in advance.

Hi All,

Did anyone get the chance to look at the above post.

Thanks a lot for your help in advance. :)

Hi All,

Finally I got a code which uses dataobject method to copy the data from excel sheet to Oulook Meeting request body, It works great now but still the only thing which is not working as per my requirement is the data table (present in excel sheet) which doesn't get pasted with it's format. Is there any way to get the formatting to the same ?. Can we use the Rich Text format or Bitmap to paste only the data table ?. Please help..

Attached is my macro workbook for your reference.

Thanks a lot for your help in advance.:)

Hi All,

Did anyone get the chance to look into the above post. ?

Thanks a lot for your help in advance.:)

Hi All,

Did anyone get the chance to look into the above post. ?

Thanks a lot for your help in advance.:)

Hi All,

Did anyone get the chance to look into the above post. ?

Thanks a lot for your help in advance.:)

I haven't tried to use VBA with meeting requests. When I've used VBA to generate e-mails I normally use
.Format = HTML
which sets the format to my usual default.
From there I would imagine that you could apply formats to the text within the invitation text. Is there any reason you don't want to use .Format = HTML

Hi Resource Dragon,

Thanks a lot for your reply, I have MS Outlook 2003 installed on my office system which doesn't support HTML format for meeting invites and that's why I am looking for other options.

Thanks a lot for your help in advance.:)

Hi All,

Did anyone get the chance to look into the above post ?.


Thanks a lot for your help in advance.:)

Hi All,

Did anyone get the chance to look at the above post ?.


Thanks a lot for your help in advance.:)

Hi All,

Did anyone get the chance to look at the above post ?.


Thanks a lot for your help in advance.:)

This is great, thanks.

However i'm facing a problem- it seems to crash my outlook every now and then (outlook 2010, ive already changed the references).

Any ideas ?