Windows 10 / Office 2016 - 运行宏时未附加所选项目

Question

由于某种原因，当我从我的宏创建新邮件时，我无法从我的收件箱中获取作为附件作为附件的选定项目。我正在使用 Windows 10 / Outlook 2016。我在 Windows 7 Office 2010 中使用了这个，但我不确定为什么它现在不起作用。任何帮助将不胜感激。

Sub SendEmail()
    Dim Inbox As Object
    Dim MyItem As Object
    Dim AddEmail As Boolean
    Dim i As Long
    Dim iAnswer As VbMsgBoxResult


    'Check if User wants to copy an existing email to new form
    iAnswer = MsgBox(Prompt:=" Do you want to copy the selected email to new form? (If you select YES, Keep the current email selected - DO NOT SELECT ANOTHER EMAIL - Until you finish sending)", _
    Buttons:=vbYesNo, Title:="Copy Selected Email")
    If iAnswer = vbYes Then
        AddEmail = True
    End If

    'Check Version of Outlook (2007 vs 2010)
    If Outlook.Application.Version = "12.0.0.6680" Then
        On Error GoTo FolderError:
        Set Inbox = Outlook.Application.GetNamespace("MAPI").Folders("Mailbox - @Incoming_Workshare")
        On Error Resume Next
    Else
        On Error GoTo FolderError:
        Set Inbox = Outlook.Application.GetNamespace("MAPI").Folders("@Incoming_Workshare")
        On Error Resume Next
    End If


    'Open Form From Folder (The Inbox =)
    Set MyItem = Inbox.Items.Add("IPM.Note.Workflow Sharing 2016")
    MyItem.Display
    MyItem.Subject = "Automatically Generated Based on Job Information"

    'Check Version of VBA and Form to make sure you are using latest macro
    If Not MyItem.Mileage = 11 Then
        'Check if User wants to copy an existing email to new form
        iAnswer = MsgBox(Prompt:="ALERT - Macro has been updated - Select Yes to Update" & vbCrLf & "(Note: Outlook will be restarted)", _
          Buttons:=vbYesNo, Title:="Automatic Macro Update")
        If iAnswer = vbYes Then
            Shell "wscript C:\Macro\UpdateOutlookMacro.vbs", vbNormalFocus
        End If
    End If

    'Copy Selected Emails to New Email if you selected Yes
    If AddEmail = True Then 
        'Check if a there is a reference to the long access time projects in the subject or body to add instructions to also send as attachment (LARGE PROJECTS)
        If InStr(1, UCase(ActiveExplorer().Selection.Item(1).Subject), "TUCAN") > 0 Or _
           InStr(1, UCase(ActiveExplorer().Selection.Item(1).Subject), "RUDY") > 0 Or _
           InStr(1, UCase(ActiveExplorer().Selection.Item(1).Subject), "SARGENT") > 0 Then
            MyItem.HTMLBody = "<b>Additional Instructions from Originating Location:</b>" & Chr(11) & "PLEASE SEND BACK HYPERLINKS AND ATTACHMENTS FOR ALL EDITED FILES" & Chr(11) & Chr(11) & Chr(11) & Chr(11) & "---------------------------------------------" & Chr(11) & "Original Banker Email:" & Chr(11)
        Else
            MyItem.HTMLBody = "<b>Additional Instructions from Originating Location:</b>" & Chr(11) & Chr(11) & Chr(11) & Chr(11) & Chr(11) & "---------------------------------------------" & Chr(11) & "Original Banker Email:" & Chr(11)
        End If

        MyItem.BodyFormat = olFormatRichText

        'Check large job 15MB
        If (ActiveExplorer().Selection.Item(1).Size >= 15728640) Then
            MsgBox "Alert! The attached original email size is " & Format(ActiveExplorer().Selection.Item(1).Size / 1048576, 0#) & " MBs. There are errors when sending large emails. Please save attachments as links to reduce the filesize.", , Title:="Email Size Too Big"
        End If

        MyItem.Attachments.Add ActiveExplorer().Selection.Item(1)

        'Check if Sender is an autoforward from a mailbox, alerting to be manually updated
        MyItem.UserProperties("Clocker") = ActiveExplorer().Selection.Item(1).SenderName + "; " + ActiveExplorer().Selection.Item(1).CC

        If MyItem.UserProperties("Clocker") = "OH Mail; " Or MyItem.UserProperties("Clocker") = "NO Mail; " Or MyItem.UserProperties("Clocker") = "LAV Mail; " Or MyItem.UserProperties("Clocker") = "OK Mail; " Or MyItem.UserProperties("Clocker") = "WY Mail; " Then
            'MsgBox "Alert! Please populate the Requestor/Clocker field. It cannot be listed as the Advisory Presentation Mailbox"
            'MyItem.UserProperties("Clocker") = "" ' Removed Q4
            Dim CorrectedClocker1, CorrectedClocker2, CorrectedClocker3 As String
            Correctedclocker1 = Trim(SuperMid(ActiveExplorer().Selection.Item(1).body, "From:", "Sent:"))
            If InStr(ActiveExplorer().Selection.Item(1).body, "Cc:") > 0 Then
                CorrectedClocker2 = Trim(SuperMid(ActiveExplorer().Selection.Item(1).body, "To:", "Cc:"))
                CorrectedClocker3 = Trim(SuperMid(ActiveExplorer().Selection.Item(1).body, "Cc:", "Subject:"))
            Else
                CorrectedClocker2 = Trim(SuperMid(ActiveExplorer().Selection.Item(1).body, "To:", "Subject:"))
                CorrectedClocker3 = ""
            End If

            CorrectedClocker2 = Replace(CorrectedClocker2, "@Completed", "")
            CorrectedClocker3 = Replace(CorrectedClocker3, "@Completed", "")

            MyItem.UserProperties("Clocker") = CorrectedClocker1 & "; " & CorrectedClocker2 & "; " & CorrectedClocker3

        Else
            If InStr(MyItem.UserProperties("Clocker"), "[Cvcs]") > 0 Then

Answer 1

这是否在 Outlook VBA 中运行？ Attachments.Add 行应该如下吗？

MyItem.Attachments.Add Outlook.Application.ActiveExplorer.Selection.Item(1)

摆脱“On Error Resume Next”语句 - 它们隐藏了运行时错误。

Answer 2

如果您想将邮箱项目添加为新邮件的附件。 您需要将Outlook.OlAttachmentType 属性设置为olEmbeddeditem。 您可以参考下面的代码添加邮件作为附件。

Sub ResolveName()

 Dim myItem As Object

 Dim Item As Object

 Dim myFolder As Folder
 Set myNamespace = Application.GetNamespace("MAPI")
 Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
 Set myItem = Application.CreateItem(olMailItem)
 Set Item = myFolder.Items(2)
'Item.Display
 myItem.Attachments.Add Item, Outlook.OlAttachmentType.olEmbeddeditem, 1, "first"
 myItem.Display
End Sub