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 !!
>>> use code - tags <<<
>>> use code - tags <<<
Code:
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
Last edited by a moderator: