#1
|
|||
|
|||
VBA to change 'From' on drafts
Hi guys
I've been working on this VBA that changes the 'From' address on selected drafts. It works, BUT let's say I have three drafts selected, then it's only doing it for the first draft of the selection, and not all of them. Any thoughts? Thanks a lot James Sub ChangeSenderOnSelectedDraftEmails() Dim xSelection As Selection Dim xPromptStr As String Dim xYesOrNo As Integer Dim i As Long Dim xNewMail As MailItem Dim xTmpPath, xFilePath As String On Error Resume Next If Outlook.Application.Session.GetDefaultFolder(olFol derDrafts).Name <> _ Outlook.Application.ActiveExplorer.CurrentFolder.N ame Then MsgBox "Please select drafts in the root draft folder, not a sub folder." Exit Sub End If Set xSelection = Outlook.Application.ActiveExplorer.Selection If xSelection.Count > 0 Then xPromptStr = "Are you sure to change the 'From' on the selected " & xSelection.Count & " draft item(s)?" xYesOrNo = MsgBox(xPromptStr, vbQuestion + vbYesNo) If xYesOrNo = vbYes Then For i = xSelection.Count To 1 Step -1 If i = 1 Then Set xNewMail = Outlook.Application.CreateItem(olMailItem) With xNewMail .SendUsingAccount = xSelection.Item(i).SendUsingAccount .To = xSelection.Item(i).To .SentOnBehalfOfName = "mynewaddress@test.com" .CC = xSelection.Item(i).CC .BCC = xSelection.Item(i).BCC .Subject = xSelection.Item(i).Subject If xSelection.Item(i).Attachments.Count > 0 Then xTmpPath = "C:\MyTempAttachments" If Dir(xTmpPath, vbDirectory) = "" Then MkDir xTmpPath End If For k = xSelection.Item(i).Attachments.Count To 1 Step -1 xFilePath = xTmpPath & "" & xSelection.Item(i).Attachments.Item(k).FileName xSelection.Item(i).Attachments.Item(k).SaveAsFile xFilePath xNewMail.Attachments.Add (xFilePath) Kill xFilePath Next k RmDir xTmpPath End If .HTMLBody = xSelection.Item(i).HTMLBody .Save End With xSelection.Item(i).Delete Else xSelection.Item(i).Save End If Next MsgBox "Successfully changed 'From' on " & xSelection.Count & " messages" End If Else MsgBox "No drafts selected!" End If End Sub |
#2
|
||||
|
||||
Your code only processes the first item selected
Code:
If i = 1 Then
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
|||
|
|||
Quote:
Oh there's the culprit! What should I change this to? I am by no means an expert and just trying to learn as I go along Thanks a lot! |
#4
|
||||
|
||||
You should delete it and the rest of the condition i.e.
Code:
Else xSelection.Item(i).Save End If Code:
xSelection.Item(i).Delete
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#5
|
|||
|
|||
What a legend!!!! That's worked, incredible. I've left the Delete bit so that it removes the original draft file. But yes, that's perfect! Thank you sooooo much, you're a life saver. Have a wonderful week!
|
#6
|
|||
|
|||
Hi guys
FYI just thought I'd share that I was encountering an issue that created header.htm attachment when using this macro, so I've changed this so it no longer creates a new mailitem. This seems to work well, so thought I'd share! Sub ChangeSenderOnSelectedDraftEmails() Dim xSelection As Selection Dim xPromptStr As String Dim xYesOrNo As Integer Dim i As Long Dim myOlApp As New Outlook.Application Dim myNameSpace As Outlook.NameSpace Dim mySourceFolder As Outlook.MAPIFolder Dim myNewFolder As Outlook.MAPIFolder Set myNameSpace = myOlApp.GetNamespace("MAPI") Set mySourceFolder = myNameSpace.GetDefaultFolder(olFolderDrafts) Set xSelection = Outlook.Application.ActiveExplorer.Selection Dim Message, Title, Default, MyValue Message = "Type in the new 'From' email address. Please note: you must already have access to the account." ' Set prompt. Title = "'From' address" ' Set title. Default = "@mynewemail.com" ' Set default. ' Display message, title, and default value. MyValue = InputBox(Message, Title, Default) If xSelection.count > 0 Then xPromptStr = "Are you sure to change the 'From' on the selected " & xSelection.count & " draft item(s)?" xYesOrNo = MsgBox(xPromptStr, vbQuestion + vbYesNo) If xYesOrNo = vbYes Then For i = xSelection.count To 1 Step -1 For Each Draftmail In xSelection Draftmail.SentOnBehalfOfName = MyValue Draftmail.Save Next Next MsgBox "Successfully changed 'From' on " & xSelection.count & " messages" End If Else MsgBox "No drafts selected!" End If End Sub |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Outlook rule to move emails from drafts into a draft subfolder | gazmoz17 | Outlook | 0 | 10-03-2019 06:34 AM |
word 2016 won't change to drafts for default view | infonutt | Word | 0 | 07-21-2017 10:31 AM |
My draft message gets deleted from drafts when I send it? | Bansaw | Outlook | 2 | 07-28-2011 08:45 AM |
autosaving drafts with digital signature in outlook 2010 | lvovich | Outlook | 0 | 04-11-2011 12:40 AM |
Sent Items in Saved in Drafts | trish@25by7.com | Outlook | 1 | 11-05-2010 02:33 AM |