For some reason, I can't get the selected item which would be an email from my inbox to attach as an attachment when I create a new mail from my macro. I'm using Windows 10 / Outlook 2016. I had this working in Windows 7 Office 2010, but I'm not sure why it's not working now. Any help would be greatly appreciated.
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
Is this running inside Outlook VBA?. Should Attachments.Add line be the following?
MyItem.Attachments.Add Outlook.Application.ActiveExplorer.Selection.Item(1)
Get rid of the "On Error Resume Next" statements - they are hiding runtime errors.