Microsoft Office Forums

Go Back   Microsoft Office Forums > >

 
 
Thread Tools Display Modes
Prev Previous Post   Next Post Next
  #1  
Old 02-10-2021, 02:39 AM
JamesWood JamesWood is offline VBA to change 'From' on drafts Windows 10 VBA to change 'From' on drafts Office 2019
Advanced Beginner
VBA to change 'From' on drafts
 
Join Date: Nov 2020
Posts: 37
JamesWood is on a distinguished road
Question 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
Reply With Quote
 



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
VBA to change 'From' on drafts 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

Other Forums: Access Forums

All times are GMT -7. The time now is 08:02 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2025, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2025 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft