Send appointment to Outlook mail RRS feed

  • Question

  • Dears, 

    i need support please as i have a VBA code that let me appointment to Outlook mail via excel, when run the below code nothing is reflect neither doing action nor view an bug in VBA. appreciate if share with me around a solution for this trouble  

    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 myPath As String
        Application.ScreenUpdating = False
        myPath = ActiveWorkbook.Path
        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
                .MeetingStatus = olMeeting
                ' read appointment values from the worksheet
                On Error Resume Next
                .Start = Cells(r, 1).Value + Cells(r, 2).Value
                .End = Cells(r, 1).Value + Cells(r, 3).Value
                .Start = Cells(r, 1).Value + Cells(r, 4).Value
                .End = Cells(r, 1).Value + Cells(r, 5).Value
                .Start = Cells(r, 1).Value + Cells(r, 6).Value
                .End = Cells(r, 1).Value + Cells(r, 7).Value
                .Subject = Cells(r, 8).Value
                .Location = Cells(r, 9).Value
                .ReminderSet = Cells(r, 12).Value
                .Importance = Right(Cells(r, 13).Value, 1)
                .RequiredAttendees = Cells(r, 14).Value
                .Categories = "TestAppointment"    ' add this to be able to delete the testappointments
                .ReminderSet = True
                .ReminderMinutesBeforeStart = 5
                On Error GoTo 0
                .MeetingStatus = olMeeting 'So the "To" field is visible, and will be emails rather than saved
                .Send   ' saves the new appointment to the default folder
            End With
            r = r + 1
        Set olAppItem = Nothing
        Set olApp = Nothing
        Application.ScreenUpdating = True
    End Sub

    The Shared Workbook


    Monday, December 22, 2014 12:34 PM

All replies

  • Hello Ahmed,

    Did you try to debug the code?

    Anyway, I see the following code above:

      .RequiredAttendees = Cells(r, 14).Value

    The RequiredAttendees property value only contains the display names for the required attendees. The attendee list should be set by using the Recipients collection.

       .Start = Now
       .End = Now

    Also I'd suggest changing the Start and End property values.

    Monday, December 22, 2014 1:06 PM
  • Hello Eugene,

    about the 1st remark: you mean to use  the display name instead of using the mail?

    about the 2nd remark: could you please provide me with additional info about that case or how can i apply it with my case, as i'm not familiar with Outlook coding

    Thanks a lot,  

    Monday, December 22, 2014 3:02 PM
  • Something like this?

    Sub AppointmentAutomation()
        Dim OutApp As Object
        Set OutApp = CreateObject("Outlook.Application")
        Dim oAppt As AppointmentItem
        Dim oPattern As RecurrencePattern
        Set oAppt = OutApp.CreateItem(olAppointmentItem)
        Set oPattern = oAppt.GetRecurrencePattern
        With oPattern
            .RecurrenceType = olRecursWeekly
            .DayOfWeekMask = olMonday
            .PatternStartDate = Worksheets("Sheet1").Range("A2")
            .PatternEndDate = Worksheets("Sheet1").Range("B2")
            .Duration = 60
            .StartTime = Worksheets("Sheet1").Range("C2")
            .EndTime = Worksheets("Sheet1").Range("D2")
        End With
        oAppt.Subject = Worksheets("Sheet1").Range("E2")
    Set OutApp = Nothing
    End Sub

    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Monday, December 29, 2014 8:29 PM