VBA to change 'From' on drafts

[JamesWood]

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

[gmayor]

Your code only processes the first item selected

If i = 1 Then

[JamesWood]

Originally Posted by gmayor

Your code only processes the first item selected

If i = 1 Then

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!

[gmayor]

You should delete it and the rest of the condition i.e.

                Else
                    xSelection.Item(i).Save
                End If

if you want it to process all the items. At present it just processes one item and saves all the rest. I suspect I would also want to remove the line

xSelection.Item(i).Delete

so that if the code does not do what you require, you won't lose the messages.

[JamesWood]

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!

[JamesWood]

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