Excel в Outlook: .Send возвращает ошибку во время выполнения - PullRequest
Новая
       14

Excel в Outlook: .Send возвращает ошибку во время выполнения

0 голосов
/ 08 ноября 2018

Об этом уже спрашивали, однако я проверил все предыдущие решения, и ни одно из них не сработало, поэтому я спрашиваю здесь.

У меня есть код Excel, который отправляет электронное письмо, если выполняется определенный набор условий. Я трижды проверил свои данные, и там не было ошибок. Теперь код работал нормально несколько дней назад, и внезапно я получаю Run-Time error '287': Application-defined or object-defined error. в строке .Send. Когда я использую .Display, он работает нормально, но, очевидно, мне нужно вручную отправить письмо.

Вот мой код: 

Sub mailing()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim lastrow As Long
    Dim ws As Worksheet


        lastrow = Worksheets("2018").Cells(Rows.Count, "Y").End(xlUp).Row
        Dim rgRem1 As Range 'rg, Reminder 1
        Dim rgRem2 As Range 'Reminder 2
        Dim rgRem3 As Range 'Reminder 3
        Dim rgAssigned As Range 'rg2, days since assigned

        Set ws = Worksheets("2018")

        With ws
            lastrow = .Cells(Rows.Count, "G").End(xlUp).Row
            Set rgAssigned = Range(.Cells(1, "X"), .Cells(lastrow, "X"))
            Set rgRem1 = Range(.Cells(1, "Y"), .Cells(lastrow, "Y"))
            Set rgRem2 = Range(.Cells(1, "z"), .Cells(lastrow, "z"))
            Set rgRem3 = Range(.Cells(1, "aa"), .Cells(lastrow, "aa"))
        End With

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")



    For Each cell In rgRem1
        Set OutMail = OutApp.CreateItem(0)
        If cell.Value = "SENDING" Then      'try with less conditions first
            With OutMail
                .To = Cells(cell.Row, "V").Value
                .Subject = "WO# " & Cells(cell.Row, "G").Value & " -  Reminder"
                .Body = "Work Order: " & Cells(cell.Row, "G").Value & _
                    " has been assigned to you for " & Cells(cell.Row, "x").Value & " days and is not yet completed. Can you provide any updates?" & _
                    vbNewLine & vbNewLine & _
                    "Region: " & Cells(cell.Row, "B").Value & vbNewLine & _
                    "District: " & Cells(cell.Row, "C").Value & vbNewLine & _
                    "City: " & Cells(cell.Row, "D").Value & vbNewLine & _
                    "Atlas: " & Cells(cell.Row, "E").Value & vbNewLine & _
                    "Notification Number: " & Cells(cell.Row, "F").Value & vbNewLine
                '.ReadReceiptRequested = True
                .Send
            End With
            Cells(cell.Row, "Y").Value = Now
            Set OutMail = Nothing
        End If

        Next cell

    For Each cell In rgRem2
        Set OutMail = OutApp.CreateItem(0)
        If cell.Value = "SENDING" Then      'try with less conditions first
            With OutMail
                .To = Cells(cell.Row, "V").Value
                .Subject = "WO# " & Cells(cell.Row, "G").Value & " - Reminder"
                .Body = "Work Order: " & Cells(cell.Row, "G").Value & _
                    " has been assigned to you for " & Cells(cell.Row, "x").Value & " days and is not yet completed. Can you provide any updates?" & _
                    vbNewLine & vbNewLine & _
                    "Region: " & Cells(cell.Row, "B").Value & vbNewLine & _
                    "District: " & Cells(cell.Row, "C").Value & vbNewLine & _
                    "City: " & Cells(cell.Row, "D").Value & vbNewLine & _
                    "Atlas: " & Cells(cell.Row, "E").Value & vbNewLine & _
                    "Notification Number: " & Cells(cell.Row, "F").Value & vbNewLine
                '.ReadReceiptRequested = True
                .Send
            End With
            Cells(cell.Row, "z").Value = Now
            Set OutMail = Nothing
        End If

        Next cell


    For Each cell In rgRem3
        Set OutMail = OutApp.CreateItem(0)
        If cell.Value = "SENDING" Then      'try with less conditions first
            With OutMail
                .To = Cells(cell.Row, "V").Value
                .Subject = "WO# " & Cells(cell.Row, "G").Value & " - Reminder"
                .Body = "Work Order: " & Cells(cell.Row, "G").Value & _
                    " has been assigned to you for " & Cells(cell.Row, "x").Value & " days and is not yet completed. Can you provide any updates?" & _
                    vbNewLine & vbNewLine & _
                    "Region: " & Cells(cell.Row, "B").Value & vbNewLine & _
                    "District: " & Cells(cell.Row, "C").Value & vbNewLine & _
                    "City: " & Cells(cell.Row, "D").Value & vbNewLine & _
                    "Atlas: " & Cells(cell.Row, "E").Value & vbNewLine & _
                    "Notification Number: " & Cells(cell.Row, "F").Value & vbNewLine
                '.ReadReceiptRequested = True
                .Send
            End With
            Cells(cell.Row, "aa").Value = Now
            Set OutMail = Nothing
        End If

        Next cell



    'Set OutApp = Nothing                        'it will be Nothing after End Sub
    Application.ScreenUpdating = True

    'For Each cell In rgAssigned
        'If cell.Value = 25 And cell.Value <> "Completed" And cell.Value <> "Over 75 days since assigned" And cell.Value <> "" And Cells(cell.Row, "Y").Value = "" Then
        'Cells(cell.Row, "Y").Value = "SENDING"
        'End If

        'If cell.Value = 50 And cell.Value <> "Completed" And cell.Value <> "Over 75 days since assigned" And cell.Value <> "" And Cells(cell.Row, "Z").Value = "" Then
        'Cells(cell.Row, "Z").Value = "SENDING"
        'End If

        'If cell.Value = 75 And cell.Value <> "Completed" And cell.Value <> "Over 75 days since assigned" And cell.Value <> "" And Cells(cell.Row, "AA").Value = "" Then
        'Cells(cell.Row, "AA").Value = "SENDING"
        'End If
    'Next cell
End Sub

Я пробовал несколько решений, предлагаемых онлайн, в том числе:

  1. Проверка настроек моего центра управления безопасностью - они установлены, как показано на этом изображении .
  2. Использование .SendKeys (оба .SendKeys "%S" и .SendKeys "^{ENTER}")
  3. Использование .SendMail
  4. Включение всех ссылок (в Excel), связанных с Microsoft Scripting Runtime, Outlook и объектными библиотеками
  5. Запуск кода как с открытым Outlook, так и с закрытым Outlook
  6. Я избегаю решения для слияния, так как этот Excel предназначен для использования несколькими людьми, каждый с одинаковыми настройками центра управления безопасностью, но с разными настройками слияния

У меня есть автоматизация электронной почты в нескольких моих макросах, и ни один из них не работает. Моя безопасность не изменилась, и мой компьютер не получал серьезных обновлений с тех пор, как я в последний раз использовал этот Excel. Если у кого-нибудь есть какие-либо исправления или информация, которая может мне помочь - , которая не включает или только повторяет решения, которые я уже тестировал - я был бы очень признателен. Я задал этот вопрос на mrexcel.com/forum в отношении аналогичного, но другого кода, и я обращаюсь к нему, так как я еще не получил никакого ответа.

EDIT:

Вот дополнительная информация о моих ссылках в Excel:

References

Ответы [ 3 ]

0 голосов
/ 08 ноября 2018

У меня была такая же проблема несколько лет назад из-за нашей политики электронной почты, запрещающей удаленную отправку, поэтому я добавил код в Outlook для отправки черновиков при сохранении, а затем вместо .send в Excel я использовал .save. Это выполняется на моей виртуальной машине, поэтому Я гарантирую, что он случайно не отправит что-то, что я готовлю, я бы не рекомендовал это на вашем обычном компьютере. Это странное решение, но оно работает.

Код Outlook: 

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Set objNS = GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderDrafts).Items
Set objNS = Nothing
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
EmailOutlookDraftsMessages
End Sub

Public Sub EmailOutlookDraftsMessages()
Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder
Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders
Set myDraftsFolder = myFolders("insight@brickworks.com.au").Folders("Drafts")
For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
If Len(Trim(myDraftsFolder.Items.Item(lDraftItem).To)) > 0 Then
    myDraftsFolder.Items.Item(lDraftItem).Send
End If
Next lDraftItem
Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing
End Sub

Надеюсь, это поможет, пойте, если вы застряли.

0 голосов
/ 08 ноября 2018

Огромное спасибо Dan Donoghue , который создал этот код и помог мне разместить его в правильном месте: ThisOutlookSession в Outlook VBA. Я немного подправил его, чтобы он отправлял только черновики, которые имеют получателя и содержат определенную текстовую строку, включенную в тему. Я надеюсь найти способ настроить его так, чтобы мое письмо не нужно было вводить вручную. 

Private WithEvents Items As Outlook.Items
    Private Sub Application_Startup()
    Dim objNS As Outlook.NameSpace
    Set objNS = GetNamespace("MAPI")
    Set Items = objNS.GetDefaultFolder(olFolderDrafts).Items
    Set objNS = Nothing
    End Sub

    Private Sub Items_ItemAdd(ByVal Item As Object)
    EmailOutlookDraftsMessages
    End Sub

    Public Sub EmailOutlookDraftsMessages()
    Dim lDraftItem As Long
    Dim myOutlook As Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolders As Outlook.Folders
    Dim myDraftsFolder As Outlook.MAPIFolder
    Set myOutlook = Outlook.Application
    Set myNameSpace = myOutlook.GetNamespace("MAPI")
    Set myFolders = myNameSpace.Folders
    Set myDraftsFolder = myFolders("R.E.L.s_email@fake.com").Folders("Drafts")
    For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
    If Len(Trim(myDraftsFolder.Items.Item(lDraftItem).To)) > 0 And InStr(myDraftsFolder.Items.Item(lDraftItem).Subject, "WO# ") > 0 Then
        myDraftsFolder.Items.Item(lDraftItem).Send
    End If
    Next lDraftItem
    Set myDraftsFolder = Nothing
    Set myNameSpace = Nothing
    Set myOutlook = Nothing
    End Sub
0 голосов
/ 08 ноября 2018

Если он работает несколько дней назад, возможно, он заблокирован портом 'smtp' или проверкой 'ssl'? это может быть вызвано сервером isp также, если он существует .. последний момент, о котором я могу подумать ... может быть, сама служба времени выполнения попадает в процедуру сценариев (если это случится, есть файл журнала ..) если это произойдет, я предлагаю переустановить среду выполнения Outlook или службу отладчика, или и то, и другое ..

...