olAppointmentItem & .SendUsingAccount not working

Occasional Visitor

Just a quick introduction to what I'm trying to do, and the roadblock I'm encountering.
I'm attempting to automate with VBA sending a calendar invite, but doing so on behalf of another. When I run the code below, the calendar invite populates just fine with all of the relevant information (date, time, body, etc.), but instead of sending on behalf of (or from) the designated email address, it still sends it from my own email.

I have also tried using .SendOnBehalfOfName in place of .SendUsingAccount, and that throws an error ("Object doesn't support this property or method")

Any help would be appreciated. PLEASE NOTE: "Cells(r, 10).Value" is the cell where the "on behalf of" email address exists in the worksheet. I have also tried just entering the "on behalf of" email address in this spot in quotation marks.


I should add that, yes, I have full access to the "on behalf of" email address.
When I attempt to schedule something on behalf of that email address manually in Outlook, it works just fine.





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
            .SendUsingAccount = Cells(r, 10).Value
            .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
                .BusyStatus = Cells(r, 5).Value
            End If

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

            .Body = Cells(r, 7).Value
            r = r + 1
        End With
End Sub




1 Reply


Hi, I've got the very same problem. Dis you fix it and how please?

Thanks in advance