Question

我已经在以下代码上工作了好几天，希望最终产品可以做两件事。

向团队组织者发送电子邮件，其中包含电子表格中的详细信息。向预约评估员发送预约预约，并附上约会详情。

我收到一条错误消息：

编译错误：

如果没有阻止，则结束

Sub ACarr_Step2()
    Dim iRet As Integer
    Dim strPrompt As String
    Dim strTitle As String

    ' Promt
    strPrompt = "Have you checked if Joe Bloggs is available?"

    ' Dialog's Title
    strTitle = "Availability Confirmation"

    'Display MessageBox
    iRet = MsgBox(strPrompt, vbYesNo, strTitle)

    ' Check pressed button
    If iRet = vbNo Then
        MsgBox "Please check Availability with Joe Bloggs"
    Else
          Dim OutApp As Object
    Dim OutMail As Object

    assessor = Sheets("ACarr").Range("AB5").Text
    clerk = Sheets("ACarr").Range("AB1").Text
    team = Sheets("ACarr").Range("AB2").Text
    datee = Sheets("ACarr").Range("AB3").Text
    timeslot = Sheets("ACarr").Range("AB4").Text

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "Team.organizer@company.co.uk"
        .CC = ""
        .BCC = ""
        .Subject = "DSE Assessment Booking"
        .Body = "Hi there," & vbNewLine & vbNewLine & "Could you please arrange for the agents below to be rota'd off to complete a Desk Assessment." & vbNewLine & vbNewLine & "Assessor: " & assessor & vbNewLine & "Staff Member : " & clerk & vbNewLine & "Team: " & team & vbNewLine & "Date: " & datee & vbNewLine & "Time Slot: " & timeslot & vbNewLine & vbNewLine & "Thank You"

        .send

' Create the Outlook session
Set myoutlook = CreateObject("Outlook.Application")
' Create the AppointmentItem
Set myapt = myoutlook.CreateItem(olAppointmentItem)     ' Set the appointment properties
With myapt
    .Subject = "DSE Assessment Booking"
    .Location = Sheets("ACarr").Range("AB2").Text
    .Start = Sheets("ACarr").Range("AB4").Text
    .Duration = 30
    .Recipients = "Desk.Assessor@Company.co.uk"
    .MeetingStatus = olMeeting
    ' not necessary if recipients are email addresses
    'myapt.Recipients.ResolveAll
    .AllDayEvent = "False"
    .BusyStatus = "2"
    .ReminderSet = False
    .Body = "Hi there," & vbNewLine & vbNewLine & "Could you please arrange for the agents below to be rota'd off to complete a Desk Assessment." & vbNewLine & vbNewLine & "Assessor: " & assessor & vbNewLine & "Staff Member : " & clerk & vbNewLine & "Team: " & team & vbNewLine & "Date: " & datee & vbNewLine & "Time Slot: " & timeslot & vbNewLine & vbNewLine & "Thank You"
        .Save
    .send

        Application.ScreenUpdating = False
    Sheets("ACarr").Activate
    Range("C14").Select
    Selection.ClearContents
    Range("C20").Select
    Selection.ClearContents
    Range("C26").Select
    Selection.ClearContents
    Range("C32").Select
    Selection.ClearContents
    Sheets("Menu").Activate
    'enable the application to show screen switching again
    Application.ScreenUpdating = True

    ActiveWorkbook.Save

    MsgBox "Your Email has been sent and changes saved."

    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

  End If

End Sub

据我所知，我有足够数量的结束Ifs作为Ifs的数量。

Answer 1

我已经查看了一些代码，发现了可能影响约会发送的两件事：

您在发送之前保存，关闭窗口，因此可能无法发送
您创建了一个第二个Outlook实例，这不是必需的，并且只会使用更多的RAM（因为您不会关闭它）

所以这是你的（重新格式化的）修改过的代码，试一试：

Sub ACarr_Step2()
    Dim iRet As Integer
    Dim strPrompt As String
    Dim strTitle As String

    ' Promt
    strPrompt = "Have you checked if Joe Bloggs is available?"
    ' Dialog's Title
    strTitle = "Availability Confirmation"
    'Display MessageBox
    iRet = MsgBox(strPrompt, vbYesNo, strTitle)

    ' Check pressed button
    If iRet = vbNo Then
        MsgBox "Please check Availability with Joe Bloggs"
    Else
        Dim OutApp As Object
        Dim OutMail As Object
        Dim myApt As Object

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        assessor = Sheets("ACarr").Range("AB5").Text
        clerk = Sheets("ACarr").Range("AB1").Text
        team = Sheets("ACarr").Range("AB2").Text
        datee = Sheets("ACarr").Range("AB3").Text
        timeslot = Sheets("ACarr").Range("AB4").Text

        On Error Resume Next
        With OutMail
            .To = "Team.organizer@company.co.uk"
            .CC = ""
            .BCC = ""
            .Subject = "DSE Assessment Booking"
            .Body = "Hi there," & vbNewLine & vbNewLine & "Could you please arrange for the agents below to be rota'd off to complete a Desk Assessment." & vbNewLine & vbNewLine & "Assessor: " & assessor & vbNewLine & "Staff Member : " & clerk & vbNewLine & "Team: " & team & vbNewLine & "Date: " & datee & vbNewLine & "Time Slot: " & timeslot & vbNewLine & vbNewLine & "Thank You"

            .Send
        End With

        ' Create the Outlook session
        'Set myoutlook = CreateObject("Outlook.Application")
        ' Create the AppointmentItem
        Set myApt = OutApp.CreateItem(olAppointmentItem)     ' Set the appointment properties

        With myApt
            .Subject = "DSE Assessment Booking"
            .Location = Sheets("ACarr").Range("AB2").Text
            .Start = Sheets("ACarr").Range("AB4").Text
            .Duration = 30
            .Recipients = "Desk.Assessor@Company.co.uk"
            .MeetingStatus = olMeeting
            ' not necessary if recipients are email addresses
            'myapt.Recipients.ResolveAll
            .AllDayEvent = "False"
            .BusyStatus = "2"
            .ReminderSet = False
            .Body = "Hi there," & vbNewLine & vbNewLine & _
                        "Could you please arrange for the agents below to be rota'd off to complete a Desk Assessment." & vbNewLine & vbNewLine & _
                        "Assessor: " & assessor & vbNewLine & _
                        "Staff Member : " & clerk & vbNewLine & _
                        "Team: " & team & vbNewLine & _
                        "Date: " & datee & vbNewLine & _
                        "Time Slot: " & timeslot & vbNewLine & vbNewLine & _
                        "Thank You"
            '.Save
            .Send
        End With

        Application.ScreenUpdating = False
        With Sheets("ACarr")
            .Range("C14").ClearContents
            .Range("C20").ClearContents
            .Range("C26").ClearContents
            .Range("C32").ClearContents
        End With
        Sheets("Menu").Activate
        'enable the application to show screen switching again
        Application.ScreenUpdating = True
        ActiveWorkbook.Save

        MsgBox "Your Email has been sent and changes saved."

        On Error GoTo 0

        Set OutMail = Nothing
        Set OutApp = Nothing
        Set myApt = Nothing
    End If
End Sub

如果没有阻止结束

1 个答案: