Hello Friends, can anyone help me with the attached VBA Coding to insert a cell value [B2, D2, B4, D4] in the subject field on an email? I am new to this and have had to piece togther 'advice' from others to get this far. There are multiple emails addresses depending upon input information and if possible, I would liketo get the main body of the email to contain some of the text too.
Sub Mail_ActiveSheet()
'Resource Request Form'
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
Dim vName As String
Dim Sndrange As Range
Dim vFile As String
Dim vTo As String
Dim vCC As String
Dim MSG As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Add additional emails for each potential selection.
If Sheets("Resource Request (Planner)").Range("B3") = "Oil & Gas" Then
vTo = "mcpointon@hotmail.co.uk"
ElseIf Sheets("Resource Request (Planner)").Range("D6") = "WUK" Then
vCC = "mcpointon@hotmail.co.uk"
End If
If Sheets("Resource Request (Planner)").Range("D6") = "WNO" Then
vCC = "mcpointon@hotmail.co.uk"
End If
If Sheets("Resource Request (Planner)").Range("D6") = "WDK" Then
vCC = "mcpointon@hotmail.co.uk"
End If
If Range("B3") = "Offshore Support Vessel" Then
vTo = "mcpointon@hotmail.co.uk"
End If
If Range("B3") = "Marine" Then
vTo = "mcpointon@hotmail.co.uk"
End If
If Sheets("Resource Request (Planner)").Range("B3") = "Select" Or Sheets("Resource Request (Planner)").Range("B3") = "" Then
Sheets("Resource Request (Planner)").Range("B3").Select
MSG = "Oooops, 'SECTOR' information is missing!" _
& vbNewLine & vbNewLine & "Please identify and select the 'SECTOR' information e.g. Oil & Gas, Offshore Support, Marine etc."
MsgBox MSG, , "Close but no cigar Beef cheeks!"
ElseIf Sheets("Resource Request (Planner)").Range("D6") = "Select" Or Sheets("Resource Request (Planner)").Range("D6") = "" Then
Sheets("Resource Request (Planner)").Range("D6").Select
MSG = "Oooops, Network Company information is missing!" _
& vbNewLine & vbNewLine & "Please select the 'NETWORK COMPANY' who is running the Work Scope e.g. WDK, WNO or WUK"
MsgBox MSG, , "Try again Beef cheeks!"
End If
Set Sourcewb = ActiveWorkbook
vName = ActiveWorkbook.Name
'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")
vFile = TempFilePath & TempFileName & FileExtStr
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
.Close
End With
Workbooks("" & vName & "").Activate
Sheets("Resource Request (Planner)").Select
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "EmailSheet"
End With
Sheets("EmailSheet").Range("A1: B7").Value = Sheets("Resource Request (Planner)").Range("A1: B7").Value
Sheets("EmailSheet").Range("C1: D7").Value = Sheets("Resource Request (Planner)").Range("C1: D7").Value
Sheets("EmailSheet").Select
Sheets("EmailSheet").Range("A1: B7,C1: D7").Select
Set Sndrange = Selection
With Sndrange
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
With .Item
.To = vTo
.CC = vCC
.BCC = ""
.Subject = Worksheets("Resource Request").Range("B2;B4") & "Resource Request"
'When sending email via excel the body is the sheet
.Body = "Hello, please find attached a Resource Request Form that is included for your attention. I would be grateful if you could review the Request and let me know if you can meet the requirements within 48 hours"
.Attachments.Add vFile
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
End With
End With
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Sheets("Resource Request (Planner)").Select
Application.DisplayAlerts = False
Sheets("EmailSheet").Delete
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub