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