Email Macros to go to a SHARED Outlook mailbox Draft folder...NOT my personal Outlook Draft folder


Outlook version
Outlook 365 64 bit
Email Account
Exchange Server
Hello. I am trying to do the following. Run a macro in Excel which will attach a file in Outlook and save in the draft folder of a shared department folder. I will then go to the shared department Outlook account, review the email and click send. I need the email when received by the participant, that the email was sent by "the shared department email account" and not my work email account. I have the current script working but the draft always shows up in my work email account. I have the shared department account setup on my pc and is working properly. Any assistance is greatly appreciated !!

Sub CreateDraftEmail()
' CreateDraftEmail Macro
' Declarations

Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim AddressList As String

Dim objFso As Object
Dim objFiles As Object
Dim objSubFolder As Object
Dim objSubFolders As Object
Dim objFile As Object

Set WbOne = ActiveWorkbook
'Popping an error message if the macro is being run from a sheet other than the SAO Email spreadsheet

WorkbookName = Left(ActiveWorkbook.Name, 9)
If WorkbookName <> "SOA Email" Then
MsgBox "Please make sure that the macro is run from the SOA Email spreadsheet and start over"
ExitonError = Y
Exit Sub
End If

Sheets("SOA List").Activate

StartRowNumCount = 0
EndRowNumCount = 0

'making sure there is an input for the start row

StartRowNum = Application.InputBox("Enter the number for the row you would like to start", Type:=1)

If StartRowNum = False Then
Exit Sub
End If

'making sure there is an input for the start row
EndRowNum = Application.InputBox("Enter the number for the the row you would like to stop", Type:=1)

If EndRowNum = False Then
Exit Sub
End If

EmailCounter = 0

SOAMonth = Application.InputBox("Enter the Name of the SOA Month", Type:=2)

If SOAMonth = False Then
Exit Sub
End If

SOAYear = Application.InputBox("Enter the number SOA Year", Type:=2)

If SOAYear = False Then
Exit Sub
End If

' Setting and assigning Outlook Objects and especially a new e-mail

For EmailCounter = StartRowNum To EndRowNum

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Set WsOne = ActiveSheet

'Looking for e-mail details - To, Subject, Body, location of the file attachment etc;

email_ = Range("D" & EmailCounter)
cc_ = Range("E" & EmailCounter)
subject_ = SOAMonth & " " & SOAYear & " " & Range("G" & EmailCounter).Value
If Right(Trim(subject_), 3) <> "%%%" Then
subject_ = subject_ & "%%%"
End If

body_ = Worksheets("Body & Signature").Range("B2").Value
PHIValue = Range("F" & EmailCounter).Value
Location = Range("H" & EmailCounter).Value

With OutMail
.To = email_
.Subject = subject_
.Body = body_
.CC = cc_

'Create objects to get a count of files in the directory
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.getfolder(Location).Files
Set objSubFolders = objFso.getfolder(Location).subFolders
FileCount = objFiles.Count

'Checking to see if the e-mail distribution is for PHI attachments.
' If Distribution is lavelen PHI in column B then only files that start with "PHI"
'will be sent
'Distribution labeled "Non PHI" in column B will get the non PHI files
'Distribution labeled as neither (blank) in Column B will get all files

For Each objFile In objFiles
Filename = objFile.Name
FileName3Char = Left(Filename, 3)
If objFile.Type <> "Shortcut" Then

FileType = objFile.Type
If PHIValue = "PHI" Then
If FileName3Char = "PHI" Then
.Attachments.Add Location & "\" & Filename
End If
ElseIf PHIValue = "Non PHI" Then
If FileName3Char <> "PHI" Then
.Attachments.Add Location & "\" & Filename
End If
ElseIf PHIValue = "All" Then
.Attachments.Add Location & "\" & Filename
MsgBox ("No Valid Attachment Type was chosen for Group " & Range("C" & EmailCounter).Value & ". Please correct and restart from the row for " & Range("C" & EmailCounter).Value)
Exit Sub

End If
End If

Next objFile

'Save in the draft folder
End With
Set OutMail = Nothing
Set OutApp = Nothing

Set objOutlookMsg = Nothing

'End With
Set objOutlook = Nothing
Next EmailCounter

MsgBox ("All e-mails for rows between " & StartRowNum & " and " & EndRowNum & " have been set up. Please check your draft folder and validate the e-mails.")
End Sub
  1. Access the Shared Mailbox: To access the shared mailbox's Draft folder, you'll need to open that mailbox first. You can do this by adding the shared mailbox to your Outlook profile or by using the Namespace.GetSharedDefaultFolder method.
  2. Create a Draft Email: Use VBA to create a new email object and populate its properties (subject, body, recipients, etc.) as needed.
  3. Save to Shared Draft Folder: Instead of using MailItem.Save to save the draft to your personal Draft folder, you'll use Folder.Items.Add to add the draft to the shared mailbox's Draft folder.
Here's a sample VBA code snippet to give you an idea. Remember to adjust this code according to your specific setup:

Sub SaveDraftToSharedMailbox()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim sharedMailboxName As String
Dim sharedDraftFolder As Outlook.MAPIFolder
Dim newDraft As Outlook.MailItem

' Set the name of the shared mailbox
sharedMailboxName = ""

' Create the Outlook application and namespace objects
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")

' Log in to the shared mailbox
olNamespace.Logon sharedMailboxName

' Get the shared mailbox's Draft folder
Set sharedDraftFolder = olNamespace.GetSharedDefaultFolder(olFolderDrafts)

' Create a new draft email
Set newDraft = olApp.CreateItem(olMailItem)
newDraft.Subject = "Your Subject Here"
newDraft.Body = "Your Email Body Here"
newDraft.Recipients.Add ""

' Save the draft to the shared mailbox's Draft folder
newDraft.Save sharedDraftFolder

' Clean up
Set newDraft = Nothing
Set sharedDraftFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub

Please be aware that VBA macros can have security implications, and some organizations might have security policies that restrict or disable their use. Always ensure that you're following your organization's guidelines when using macros in Outlook.
Similar threads
Thread starter Title Forum Replies Date
nathandavies Email Details to Excel & Save as .MSG on one macro - combination of 2 macros Outlook VBA and Custom Forms 3
T How to set Default FONT for Email composing ? Using Outlook 0
H Finding text in open email Outlook VBA and Custom Forms 12
T Why do Outlook Desktop 2021 tasks from my wife's email show up in my task pane? Using Outlook 2
A Opening a link from an email automatically Outlook VBA and Custom Forms 0
D Outlook 2021 New email reminder Using accounts in Outlook 1
Rupert Dragwater How do I remove an email ending with Using Outlook 4
M A plug in (or method) to keep email message formatting after it expires Using Outlook 1
L VBA to Triage Incoming Email Outlook VBA and Custom Forms 0
R Legacy Outlook on Mac Email Cache Using Outlook 0
P Email address auto-completes work fine on laptop, but no longer on desktop Using Outlook 3
S Create Outlook Task from Template and append Body with Email Body Outlook VBA and Custom Forms 4
H Copying email address(es) in body of email and pasting in To field Outlook VBA and Custom Forms 1
A Search folder and move the email Outlook VBA and Custom Forms 0
P VBA to add email address to Outlook 365 rule Outlook VBA and Custom Forms 0
farrissf Outlook 2016 Optimizing Email Searches in Outlook 2016: Seeking Insights on Quick Search vs Advanced Search Features Using Outlook 0
D Delete selected text in outgoing email body Outlook VBA and Custom Forms 0
F Graphics in email / Mac recipient garbled Using Outlook 0
D Outlook VBA forward the selected email to the original sender’s email ID (including the email used in TO, CC Field) from the email chain Outlook VBA and Custom Forms 2
Witzker Outlook 2019 Macro to seach in all contact Folders for marked Email Adress Outlook VBA and Custom Forms 1
E Outlook 365 Save Selected Email Message as .msg File - oMail.Delete not working when SEARCH Outlook VBA and Custom Forms 0
R Outlook 365 VBA AUTO SEND WITH DELAY FOR EACH EMAIL Outlook VBA and Custom Forms 0
G Print email attachments when hit subfolder Outlook VBA and Custom Forms 1
C Spam Email? Using Outlook 2
G Automatically delete email when a condition is met Outlook VBA and Custom Forms 1
E Save Selected Email Message as .msg File - digitally sign email doesn't works Outlook VBA and Custom Forms 1
S Email was migrated from GoDaddy to Microsoft exchange. We lost IMAP ability Exchange Server Administration 1
R Outlook 365 How to integrate a third-party app with Outlook to track email and sms? Using Outlook 2
S Paperclip icon shows without attachment in email under Sent folder Using Outlook 0
B Outlook 2019 Automatically move email after assigning category Using Outlook 4
Rupert Dragwater How to permanently remove an email address Using Outlook 9
K vba code to auto download email into a specific folder in local hard disk as and when any new email arrives in Inbox/subfolder Outlook VBA and Custom Forms 0
F Auto changing email subject line in bulk Using Outlook 2
F Want to add second email to Outlook for business use Using Outlook 4
kburrows Outlook Email Body Text Disappears/Overlaps, Folders Switch Around when You Hover, Excel Opens Randomly and Runs in the Background - Profile Corrupt? Using Outlook 0
J Outlook 365 Outlook Macro to Sort emails by column "Received" to view the latest email received Outlook VBA and Custom Forms 0
A Outlook 2019 Help with forwarding email without mentioning the previous email sender. Outlook VBA and Custom Forms 0
J Macro to send email as alias Outlook VBA and Custom Forms 0
M Shift Delete doesn't delete email from server Using Outlook 3
K Incorporate selection from combobox into body of email Outlook VBA and Custom Forms 0
L Why are some email automatically going to "archive" Using Outlook 2
M Outlook Macro to save as Email with a file name format : Date_Timestamp_Sender initial_Email subject Outlook VBA and Custom Forms 0
B Outlook 2019 Custom Email form - Edit default email form Outlook VBA and Custom Forms 6
F Add a category before "Send an Email When You Add an Appointment to Your Calendar" Outlook VBA and Custom Forms 0
T Problem when requesting to view an email in a browser Using Outlook 0
J Outlook 365 Forward Email Subject to my inbox when new email arrive in shared inbox Using Outlook 0
HarvMan Archive Email Manually Using Outlook 1
L Fetch, edit and forward an email with VBA outlook Outlook VBA and Custom Forms 2
S New Email "From" box stopped working Using Outlook 0
Rupert Dragwater Duplicate email in Folder Using Outlook 7

Similar threads