Question

我不经常在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

Answer 1

B。烈火

我不确定您要创建约会还是会议？

但是，“会议”和“约会”之间的区别在于会议有与会者，而约会没有。

因此，如果要创建会议，则应设置“ olAppItem.MeetingStatus = olMeeting”属性。

有关更多信息，请查看以下链接：

AppointmentItem.MeetingStatus Property

预约邀请不会发送VBA

1 个答案: