I have created a macro that forwards an email on to a recipient once a button is clicked. However, I want the macro to also delete the email (sending it to the recycle bin).
Here is the current code. This currently works and forwards the email.
Sub forwardEmail()
Dim oExplorer As Outlook.Explorer
Dim oMail As Outlook.MailItem
Dim oOldMail As Outlook.MailItem
Set oExplorer = Application.ActiveExplorer
If oExplorer.Selection.Item(1).Class = olMail Then
Set oOldMail = oExplorer.Selection.Item(1)
Set oMail = oOldMail.forward
oMail.Recipients.Add "Recipients email goes here"
oMail.Recipients.Item(1).Resolve
If oMail.Recipients.Item(1).Resolved Then
oMail.Send
Else
MsgBox "Could not resolve " & oMail.Recipients.Item(1).Name
End If
Else
MsgBox "Not a mail item"
End If
End Sub
I thought by adding oMailItem.Delete to the code would work but it does not.
It wasn't clear to me which email you wanted deleted, the original email or the forwarded email from Sent items - so these mods provide both options.
Sub forwardEmail()
Dim oExplorer As Outlook.Explorer
Dim oMail As Outlook.MailItem
Dim oOldMail As Outlook.MailItem
Set oExplorer = Application.ActiveExplorer
If oExplorer.Selection.Item(1).Class = olMail Then
Set oOldMail = oExplorer.Selection.Item(1)
Set oMail = oOldMail.Forward
oMail.Recipients.Add "spam_me"
oMail.Recipients.Item(1).Resolve
If oMail.Recipients.Item(1).Resolved Then
'delete forwarded email from sent items
oMail.DeleteAfterSubmit = True
oMail.Send
'delete original email from inbox
oOldMail.Delete
Else
MsgBox "Could not resolve " & oMail.Recipients.Item(1).Name
End If
Else
MsgBox "Not a mail item"
End If
End Sub
Related
I go into a shared inbox and forward an email as myself, to my boss, using HTML formatting.
I wrote VBA code that works on every step except changing the From line from the shared mailbox email address to my email address.
Let's call my personal email address "gwyn#email.com" and the shared mailbox email address "office#email.com". If I manually click on the From field I can select my own email address and send it.
Public Sub ForwardIAF()
Dim OutApp As Object
Dim OutAccount As Outlook.Account
Dim myinspector As Outlook.Inspector
Dim myIAF As Outlook.MailItem
Dim myForward As Outlook.MailItem
Set myIAF = GetCurrentItem()
Set myForward = myIAF.Forward
Set OutApp = CreateObject("Outlook.Application")
Set OutAccount = OutApp.Session.Accounts.Item(1)
With myForward
.SentOnBehalfOfName = "gwyn#email.com"
Debug.Print "myForward.SentOnBehalfOfName:" & "x " & myForward.SentOnBehalfOfName & " x"
.Recipients.Add "gwyn#email.com"
.BodyFormat = olFormatHTML
.Display
End With
End Sub
When the forward opens, it shows my email address in the From line, but when I send, it reverts to the office email address. The debug print shows my email address is in the .SentOnBehalfOf field, so it looks like it's there until it sends.
Replacing .Display with .Send has the same result.
The SentOnBehalfOfName property makes sense only in case of Exchange profiles/accounts. Moreover, you need to have the required permissions to send on behalf of another person. See Issue with SentOnBehalfOfName for a similar discussion.
In case if you have multiple accounts configured in the profile you can use the SendUsingAccount property which allows to an Account object that represents the account under which the MailItem is to be sent.
Sub SendUsingAccount()
Dim oAccount As Outlook.account
For Each oAccount In Application.Session.Accounts
If oAccount.AccountType = olPop3 Then
Dim oMail As Outlook.MailItem
Set oMail = Application.CreateItem(olMailItem)
oMail.Subject = "Sent using POP3 Account"
oMail.Recipients.Add ("someone#example.com")
oMail.Recipients.ResolveAll
oMail.SendUsingAccount = oAccount
oMail.Send
End If
Next
End Sub
We are updating mails from the drafts folder and sending them a few times a day.
I want to open a selected mail resend it save it so it goes back to drafts and then close it.
I tried below
Sub DRAFT()
Dim myItem As Outlook.MailItem
Dim objInsp As Outlook.Inspector
Dim objActionsMenu As Office.CommandBarControl
Dim olResendMsg As Outlook.MailItem
' get current item & open if needed
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set myItem = Application.ActiveExplorer.Selection.Item(1)
myItem.Display
Case "Inspector"
Set myItem = Application.ActiveInspector.CurrentItem
Case Else
End Select
On Error GoTo 0
If myItem Is Nothing Then
MsgBox "Could not use current item. Please select or open a single email.", _
vbInformation
GoTo exitproc
End If
' run the resend command
Set objInsp = myItem.GetInspector
objInsp.CommandBars.ExecuteMso ("ResendThisMessage")
' save orig email
myItem.Save
' close orig email
myItem.Close
exitproc:
Set myItem = Nothing
Set objInsp = Nothing
Set objActionsMenu = Nothing
Set olResendMsg = Nothing
End Sub
You need to pass a OlInspectorClose enumeration value to the MailItem.Close method. It indicates the close behavior, i.e. the save mode. If the item displayed within the inspector has not been changed, this argument has no effect.
Name Value Description
olDiscard 1 Changes to the document are discarded.
olPromptForSave 2 User is prompted to save documents.
olSave 0 Documents are saved.
So, your code should like that:
' close orig email
myItem.Close olSave
Instead of executing the ribbon control programmatically using the CommandBars.ExecuteMso method you may try to create a cope of the source item and then send it.
The ExecuteMso method is useful in cases where there is no object model for a particular command. Works on controls that are built-in buttons, toggleButtons and splitButtons. On failure it returns E_InvalidArg for an invalid idMso, and E_Fail for controls that are not enabled or not visible.
Instead, you may use the MailItem.Copy method which creates another instance of an object.
Sub CopyItem()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Dim myItem As Outlook.MailItem
Dim myCopiedItem As Outlook.MailItem
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myNewFolder = myFolder.Folders.Add("Saved Mail", olFolderDrafts)
Set myItem = Application.CreateItem(olMailItem)
myItem.Subject = "Speeches"
Set myCopiedItem = myItem.Copy
myCopiedItem.To = "email#address.com"
myCopiedItem.Send()
End Sub
Although there is a mistake in myItem.Close, you cannot resend mail that has not been sent.
Option Explicit
Sub SendMailBasedOnPermanentDraft()
Dim myItem As MailItem
Dim objInsp As Inspector
Dim myCopyOfUnsentItemInDrafts As MailItem
' get current item & open if needed
On Error Resume Next
Select Case TypeName(ActiveWindow)
Case "Explorer"
Set myItem = ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set myItem = ActiveInspector.CurrentItem
Case Else
End Select
On Error GoTo 0
If myItem Is Nothing Then
MsgBox "Could not use current item. Please select or open a single email.", vbInformation
GoTo exitProc
End If
If myItem.Sent = False Then
Set myCopyOfUnsentItemInDrafts = myItem.copy
With myCopyOfUnsentItemInDrafts
.Subject = "Copied " & Now & ": " & myItem.Subject
.Save
.Display ' change to .Send
End With
Else
MsgBox "Select or open a single unsent email.", vbInformation
End If
exitProc:
Set myItem = Nothing
Set objInsp = Nothing
Set myCopyOfUnsentItemInDrafts = Nothing
End Sub
Below is my macro to send an email but it does not open a new email .
This macro is in the outlook rules.
Have you any ideas?
Sub sendemail()
Dim ns As NameSpace
'Dim newMail As Outlook.MailItem
Set ns = GetNamespace("MAPI")
Dim newMail As MailItem
Set newMail = Application.CreateItem()
With newMail
.To = "aaa#bbb" <--adress to whitch I want to send an email
.Subject = "test"
.Display
End With
Set newMail = Nothing
End Sub
first you need to add up the outlook reference:
There you go:
then:
Sub sendemail()
Dim outlook As New outlook.Application
Dim newMail As outlook.MailItem
Set newMail = outlook.CreateItem(olMailItem)
With newMail
.To = "email#address.com" ' <--adress to whitch I want to send an email
.Subject = "test from Steph"
.Display
.Send
End With
Set newMail = Nothing
outlook.Quit
Set outlook = Nothing
End Sub
Argument must be type MailItem or MeetingItem for the subroutine to be available in Outlook Rules Wizard.
Try this.
Option Explicit
Sub SendEmail(NewMail As Outlook.MailItem)
Set NewMail = Application.CreateItem(olMailItem)
With NewMail
.To = "aaa#bbb" '<--adress to whitch I want to send an email
.Subject = "test"
.Display
End With
Set NewMail = Nothing
End Sub
Youre not specifying the item to create. See here:
Private Sub SendEmail(ByVal workcenter As Integer, ByVal time As Date)
Dim objApp As Object
Dim objEmail As Object
Set objApp = CreateObject("Outlook.Application")
Set objEmail = CreateObject("Outlook.MailItem")
With objEmail
.To = "emailexampe#website.com"
.Subject = "Multiple Shop Orders run for line " & workcenter & " at " & time
.body = "TEST"
.display
End With
Set objEmail = Nothing
Set objApp = Nothing
End Sub
Source: http://www.vbforums.com/showthread.php?536558-RESOLVED-Outlook-late-binding
this version also uses late binding, so you dont need any additional references.
I'm trying to forward emails from my company's Outlook to an email account outside of our company. I have been given the ok to do this.
I'd like to forward any email that contains "Excel Friday" in the subject line.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
Set Msg = Item
If Msg.Subject = "Excel Friday" Then
Dim myMail As Outlook.MailItem
Set myMail = Msg.Reply
myMail.To = "xxxxxx#fakemail.com"
myMail.Display
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
I'd like to forward any email that contains "Excel Friday" in the subject line to another email address.
But in the code you check for the exact match of the subject line:
If Msg.Subject = "Excel Friday" Then
Instead you need to look for a substring. To find the position of a substring in a string, use Instr function.
If Instr(Msg.Subject, "Excel Friday") Then
Also I have noticed that you use the Reply method:
Set myMail = Msg.Reply
Use the Forward method instead:
Set myMail = Msg.Forward
And then use the Send method.
myMail.Recipients.Add "Eugene Astafiev"
myMail.Send
Be aware, the code is based on the ItemAdd event handler. This event is not fired when a large number of items are added to the folder at once (more than 16).
You can do this using a Run a Script rule
Sub ChangeSubjectForward(Item As Outlook.MailItem)
Item.Subject = "Test"
Item.Save
Set olForward = Item.Forward
olForward.Recipients.Add "Jasonfish11#domain.com"
olForward.Send
End Sub
If a vba you can run on all messages in a folder at any time.
Paste into ThisOutlookSession and run
Sub ChangeSubjectThenSend()
Dim olApp As Outlook.Application
Dim aItem As Object
Set olApp = CreateObject("Outlook.Application")
Set mail = olApp.ActiveExplorer.CurrentFolder
For Each aItem In mail.Items
aItem.Subject = "New Subject"
aItem.Save
Set olForward = aItem.Forward
olForward.Recipients.Add "Jasonfish11#domain.com"
olForward.Send
Next aItem
End Sub
source Link
I want to write a VBA script that when Outlook receive a new email from a specific email address , the VBA script has to detect that and resend the new received email to all contacts in the address book .
For now i was able to send an email to all contacts in address book :
Sub SendEmails()
Dim ContactsFolder As Folder
Set ContactsFolder = Session.GetDefaultFolder(olFolderContacts)
Dim Contact As Object
Dim olApp As Outlook.Application
Dim objMail As Outlook.MailItem
Set olApp = Outlook.Application
For Each Contact In ContactsFolder.Items
Set objMail = olApp.CreateItem(olMailItem)
With objMail
.Subject = "Subject of the received email"
.Body = "Body of the received email"
.To = Contact.Email1Address
.Send
End With
Next
End Sub
but how to use this script so it called when a new email received from a specific email address.
i tried to put this in ThisOulookSeassion to check for new message event so i could call my above code within it :
Private Sub Application_NewMail()
MsgBox "New mail"
End Sub
but it didn't work.
Also i tried this (i put it in ThisOulookSeassion too) :
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error Goto ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
' ******************
' and placing my code here.
' ******************
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
but when i click run it ask me to create new macro and don't run the code.
Any suggestions ?
The simplest way is to create a rule in Outlook. Then you can assign an existing VBA macro to run when the rule is run. Typically a VBA sub should like the following one:
Sub SendEmails(mail as MailItem)
Dim ContactsFolder As Folder
Set ContactsFolder = Session.GetDefaultFolder(olFolderContacts)
Dim objMail as MailItem
Dim Contact As Object
For Each Contact In ContactsFolder.Items
Set objMail = olApp.CreateItem(olMailItem)
With objMail
.Subject = mail.Subject
.Body = "Body Text"
.To = Contact.Email1Address
.Send
End With
Next
End Sub
Also you may consider adding recipients to the Recipients collection and set their Type to the olBCC value. Thus, each of them will recieve a separate email and you have to submit only a single mail item.