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