Приглашение на прием не отправит VBA - PullRequest
Новая
       66

Приглашение на прием не отправит VBA

0 голосов
/ 20 сентября 2018

Я не очень часто работаю в VBA, и я изменил приведенный ниже код, чтобы он соответствовал моим потребностям, и он работает вплоть до фактической отправки приглашения на встречу.Когда я открываю его в Outlook, его участник появляется в списке, но я должен отправить его вручную из Outlook.Я не получаю никаких ошибок или признаков того, что он не отправил.Любые другие советы по оптимизации и соглашениям также приветствуются, я уверен, что больно смотреть на некоторых из лучших программистов.Кроме того, я знаю, что это похоже на другие вопросы на сайте, но они достаточно разные. Мне трудно разобраться, что именно мне нужно делать, поэтому ваше терпение ценится.

Спасибо:) 

Sub RegisterAppointmentList()
'Adds a list of appointments to the Calendar in Outlook
Dim olApp As New Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long

On Error Resume Next
Worksheets("Schedule").Activate 'Insures that the correct sheet is selected, needs to be updated if rename
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0

If olApp Is Nothing Then 'If GetObject fails then creates a new Application Object

    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 = 2 'First row with appointment data in the active worksheet, ignores headers

'Declares variables for Outlook Parameters

Dim myStart, myEnd, myUnitBefore
Dim myAttendee As Outlook.Recipient

While Len(Cells(r, 1).Text) <> 0 And Len(Cells(r, 4).Text) <> 0

    'Sets Default Values of 8:00am and 8:30am as start and end times if no value found
    If Cells(r, 5) = "" Then
        myStart = DateValue(Cells(r, 4).Value) + "8:00:00 AM"
    Else:
        myStart = DateValue(Cells(r, 4).Value) + Cells(r, 5).Value    'Concatenates Date and Start Time to single value
    End If

    If Cells(r, 6) = "" Then
        myEnd = DateValue(Cells(r, 4).Value) + "8:30:00 AM"
    Else
        myEnd = DateValue(Cells(r, 4).Value) + Cells(r, 6).Value 'Concatenates Date and End Time to single value
    End If

    'Set "Minutes Before" if "Days" "Hours" or "Weeks" are selected.
    If Cells(r, 9) = "Hours" Then
        myUnitBefore = 60
    ElseIf Cells(r, 9) = "Days" Then
        myUnitBefore = 24 * 60
    ElseIf Cells(r, 9) = "Weeks" Then
        myUnitBefore = 24 * 60 * 7
    Else
        myUnitBefore = 1
    End If

    Set olAppItem = olApp.CreateItem(olAppointmentItem) 'Creates a new appointment

    With olAppItem

        On Error Resume Next
        .Subject = Cells(r, 1)
        .Location = Cells(r, 2)
        .Body = .Subject & " - " & Cells(r, 3).Value
        .Start = myStart
        .End = myEnd
        .ReminderSet = Cells(r, 7)
        .ReminderMinutesBeforeStart = Cells(r, 8).Value * myUnitBefore
        .Categories = Cells(r, 10).Text & " Category"   'Allows using dropdown to set Category.
        Set myAttendee = olAppItem.Recipients.Add(Cells(r, 11))

        If Cells(r, 12) = "Free" Then
            .BusyStatus = olFree
        Else
            .BusyStatus = olBusy
        End If

        On Error GoTo 0

        .Save 'Saves the new appointment to the default folder
        .Send 'Doesn't seem to work...

    End With

    r = r + 1 'Cycle until all rows of events have been created

Wend

'Clear Objects when done
Set olAppItem = Nothing
Set olApp = Nothing

1 Ответ

0 голосов
/ 21 сентября 2018

B.Blaze

Я не уверен, хотите ли вы создать встречу или собрание?

Однако разница между собраниями и встречами заключается в том, что на собрании присутствуют участники, а на встрече нет.

Поэтому, если вы хотите создать собрание, вам следует установить свойство «olAppItem.MeetingStatus = olMeeting».

Для получения дополнительной информации просмотрите следующую ссылку:

Свойство AppointmentItem.MeetingStatus

...