Question

我有Excel VBA代码，可生成带附件的Outlook电子邮件。

这在Windows 8.1中有效但在Windows 10中不起作用。我已经逐步完成了宏，它一直到最后，生成电子邮件，然后在OutMail.Send命令上失败。错误是

运行时错误287 - 应用程序定义或对象定义的错误

这是代码。

Sub batchallocationemail()

'define email & pdf
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim OutMail As Object

'
' print allocation Macro

'define worksheets
Dim ws As Worksheet
Set ws = Sheets("Caseworkers")
Dim ws2 As Worksheet
Set ws2 = Sheets("Allocation Sheet")
'define range
Dim NameRange As Range
Dim NameRange2 As Range
Dim x As Range
Dim z As Range
Set z = ws2.Range("B1")

Set NameRange = ws.Range("A1:C69")
Set NameRange2 = ws.Range("A2:A69")
Set NameRange3 = ws.Range("C2:C69")

'Selects name from list and pastes into allocation
ws.Select
NameRange.AutoFilter Field:=2, Criteria1:="In"
For Each x In NameRange2.SpecialCells(xlCellTypeVisible)
        x.Copy
        ws2.Select
        Range("B1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        ws2.Select
'CONVERTS ACTIVE SHEET TO PDF AND EMAILS IT
        ' Define Title
        Title = Range("B1").Value
        ' Define PDF filename
        Title = "Allocation Sheet for " & Range("B1").Value
        PdfFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Title & ".pdf"
  ' Export activesheet as PDF
        With ActiveSheet
            .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        End With
' Use already open Outlook if possible
        On Error Resume Next
        Set OutlApp = GetObject(, "Outlook.Application")
        If Err Then
            Set OutlApp = CreateObject("Outlook.Application")
            IsCreated = True
        End If
        OutlApp.Visible = True
        On Error GoTo 0

' Prepare e-mail with PDF attachment
        Set OutMail = OutlApp.CreateItem(0)
        With OutMail

' Prepare e-mail
            OutMail.Subject = Title
            OutMail.To = x.Offset(0, 2).Value ' <-- Put email of the recipient here
            OutMail.CC = x.Offset(0, 3).Value ' <-- Put email of 'copy to' recipient here
            OutMail.Body = "Hello," & vbLf & vbLf _
            & "Please see your attached allocation sheet in PDF format." & vbLf & vbLf _
            & "Kind Regards," & vbLf _
            & Application.UserName & vbLf & vbLf
            OutMail.Attachments.Add PdfFile
        ' Try to send
            Application.Visible = True
            OutMail.Display
            OutMail.Send
        End With

    ' Quit Outlook if it was not already open
        If IsCreated Then OutlApp.Quit

    ' Release the memory of object variable
        Set OutMail = Nothing
        Set OutlApp = Nothing
    Next x

End Sub

Answer 1

抱歉，我想我已修好了。我昨晚看了几个小时后发布了这个，但我似乎已经得到了它。而不是。发送我使用Application.SendKeys＆＃34;％s＆＃34;这是一个捷径。这似乎正确地发送电子邮件。

升级到Windows 10后，发送命令出现错误287

1 个答案: