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

[SB420]

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
WbOne.Activate
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;

WsOne.Activate
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
Else
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


'.Display
'Save in the draft folder
.Save
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

 

[zeinthpaul]

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 = "shared.mailbox@example.com"

' 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 "recipient@example.com"

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

' Clean up
Set newDraft = Nothing
Set sharedDraftFolder = Nothing
olNamespace.Logoff
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.

 

[Victor Ivanidze]

There exist these ready-to-use solutions:
CoolDraft add-in for Outlook and
CoolDraft flow