CODEWITHSUNDEEP
excelvbaoutlook
user1056087
user1056087

Reputation: 17

Create Outlook meeting request, with Excel data

I am working on code to create an Outlook Meeting Request to send to a list of invitees.
I see the Meeting Request in my Calendar, but I am unable to send it.
How can I get it to send?

Sub AddAppointments()
    ' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")

    ' Start at row 2
    r = 2

    Do Until Trim(Cells(r, 1).Value) = ""
        ' Create the AppointmentItem
        Set myApt = myOutlook.CreateItem(1)
        ' Set the appointment properties
        myApt.Subject = Cells(r, 1).Value
        myApt.Location = Cells(r, 2).Value
        myApt.Start = Cells(r, 3).Value
        myApt.Duration = Cells(r, 4).Value
        myApt.Recipients.Add Cells(r, 8).Value
        myApt.MeetingStatus = olMeeting
        myApt.ReminderMinutesBeforeStart = 88
        myApt.Recipients.ResolveAll
        myApt.AllDayEvent = AllDay

        ' If Busy Status is not specified, default to 2 (Busy)
        If Trim(Cells(r, 5).Value) = "" Then
            myApt.BusyStatus = 2
        Else
            myApt.BusyStatus = Cells(r, 5).Value
        End If
        If Cells(r, 6).Value > 0 Then
            myApt.ReminderSet = True
            myApt.ReminderMinutesBeforeStart = Cells(r, 6).Value
        Else
            myApt.ReminderSet = False
        End If
        myApt.Body = Cells(r, 7).Value
        myApt.Save
        r = r + 1
        myApt.Send
    Loop
End Sub

Upvotes: 1

Views: 19190

Answers (2)

user2416661
user2416661

Reputation: 1

It works for me!

Please keep in mind to have multiple lines like

.Recipients.Add Cells(r, 8).value

to add more recipients. Because writing several addresses in one cell separeted by ";" leads to an error when sendig the appointment!

or use

.Recipients.ResolveAll

Upvotes: 0

JimmyPena
JimmyPena

Reputation: 8764

Without a sample row of values, it's hard to debug this code. So we are only going on your word that it is valid. But I did fix up the code a bit.

  • You have ReminderMinutesBeforeStart twice in your code. I removed the first one because it looks like it is dependent upon row data.
  • You call the ResolveAll method, but don't check to see if your recipients resolved. If they are email addresses, I wouldn't bother.
  • There is a mix of early and late bound references. For example, you use 1 instead of olAppointmentItem, but later use olMeeting instead of 1.
  • The AllDayEvent Property takes a boolean value, but as you haven't declared any variables we have no way to tell what AllDay means. I converted this to read from column I. Also note that if you set AllDayEvent to True, you would not need to set Duration.

Assuming valid input values, this code worked for me:

Option Explicit

Sub AddAppointments()

  Dim myoutlook As Object ' Outlook.Application
  Dim r As Long
  Dim myapt As Object ' Outlook.AppointmentItem

  ' late bound constants
  Const olAppointmentItem = 1
  Const olBusy = 2
  Const olMeeting = 1

  ' Create the Outlook session
  Set myoutlook = CreateObject("Outlook.Application")

  ' Start at row 2
  r = 2

  Do Until Trim$(Cells(r, 1).value) = ""
    ' Create the AppointmentItem
    Set myapt = myoutlook.CreateItem(olAppointmentItem)
    ' Set the appointment properties
    With myapt
      .Subject = Cells(r, 1).value
      .Location = Cells(r, 2).value
      .Start = Cells(r, 3).value
      .Duration = Cells(r, 4).value
      .Recipients.Add Cells(r, 8).value
      .MeetingStatus = olMeeting
      ' not necessary if recipients are email addresses
      ' myapt.Recipients.ResolveAll
      .AllDayEvent = Cells(r, 9).value

      ' If Busy Status is not specified, default to 2 (Busy)
      If Len(Trim$(Cells(r, 5).value)) = 0 Then
        .BusyStatus = olBusy
      Else
        .BusyStatus = Cells(r, 5).value
      End If

      If Cells(r, 6).value > 0 Then
        .ReminderSet = True
        .ReminderMinutesBeforeStart = Cells(r, 6).value
      Else
        .ReminderSet = False
      End If

      .Body = Cells(r, 7).value
      .Save
      r = r + 1
      .Send
    End With
  Loop
End Sub

Sample input values in cells (incl. header row):

  • A2: My Meeting
  • B2: My Desk
  • C2: 11/25/2011 13:30:00 PM
  • D2: 30
  • E2: 2
  • F2: 30
  • G2: Let's have a meeting!
  • H2: -email address-
  • I2: FALSE

Upvotes: 8

Related Questions