VBA to forward emailed workbook instead of sending

[Lstallan]

I have been tasked with setting up an Excel spreadsheet for employees to request shift swaps.
The process requires 1 user to create the form with their details, then send the form to the person they are swapping with, then the completed form is submitted to the Duty Manager email and Admin email addresses.
In order to maintain an electronic trail of the person who created the trail, I need to record the email address of the person who created the form.
Initially I looked at trying to record the email address on the form invisibly (white text in a white cell), but had problems getting the VBA to capture the users email address who creates the form.
As an alternative I am now considering getting the code to "Forward" the existing emailed form rather than a plain "Send".
I have created the sheet and have used 2 macros - 1 to send to the next variable recipient for them to complete their half of the request, and another to submit to particular email addresses (code below courtesy Ron De Bruin)

Any suggestions on a resolution would be greatly appreciated

Sub SendMEOD()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'unprotect sheet
ActiveSheet.unprotect "password"

Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & ""
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = "Shift Swap Form"
.Body = "Please complete and submit"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display
Application.Wait (Now + TimeValue("0:00:04"))
Application.SendKeys "%s"
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing

'Protect Sheet
ActiveSheet.Protect "password", True, True

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub



Sub SubmitMEOD()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'unprotect sheet
ActiveSheet.unprotect "password"

Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & ""
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "EOCBedfordDutyManagers@eastamb.nhs.uk"
.CC = "BedfordEOCadmin@eastamb.nhs.uk"
.BCC = ""
.Subject = "Completed MEOD Form"
.Body = "Please process accordingly"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display
Application.Wait (Now + TimeValue("0:00:04"))
Application.SendKeys "%s"
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing

'Protect Sheet
ActiveSheet.Protect "password", True, True

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Lstallan]

I apologise for missing out the

tags. I tried to edit my post but for some reason I don't have permission

 

[paulxmw]

Hey
Try the following the email address in this example is kept on a sheet called Text and is in Column B row 28 but you could send each person there own version of the sheet in which case the send on behalf of would read .SentOnBehalfOfName = "someone@yourmail.com"

With OutMail
.SentOnBehalfOfName = Sheets("Text").Range("B28").Value
.to = "EOCBedfordDutyManagers@eastamb.nhs.uk"
.CC = "BedfordEOCadmin@eastamb.nhs.uk"
.BCC = ""


Hope this helped

 

[Lstallan]

Thanks for your feedback, unfortunately this doesn't capture the original senders email address. As a security measure I have been asked to record this data to ensure that 1 person isn't raising a form in another persons name, sending it to themselves and then submitting it (ie person 2 generates form using person 1 name, sends it to themselves using person 1 details without their knowledge)

it needs to be:
Person 1 creates request - their email address recorded automatically based on their exchange login
Person 2 completes form and submits - their email address is in the header that gets sent to Admin and Manager