VBA Coding to use a Cell value in a Email Subject Field

0

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

Answer
Discuss

Answers

0

The subject line is set in this part of your code (see the last line)

    With Sndrange
        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope
            With .Item
                .To = vTo
                .CC = vCC
                .BCC = ""
                .Subject = "Resource Request Form"

You can replace or modify this line in whatever way you want so long as you provide a string. Here is an example.

.Subject = "Resource Request Form " & Sheets("EmailSheet").Range"B2").Value 

To further help you in your struggle I have propertly formatted the first few thoughts of your procedure. After re-designing the spacing an applying proper indenting you can now probably see what is wrong with it.

     'Add additional emails for each potential selection.
    If Sheets("Resource Request (Planner)").Range("B3") = "Oil & Gas" Then
        vTo = "craig.pointon@wartsila.com"
    ElseIf Sheets("Resource Request (Planner)").Range("D6") = "WUK" Then
        vCC = "craig.pointon@wartsila.com"
    End If
        
    If Sheets("Resource Request (Planner)").Range("D6") = "WNO" Then
        vCC = "craig.pointon@wartsila.com"
    End If
         
    If Sheets("Resource Request (Planner)").Range("D6") = "WDK" Then
        vCC = "craig.pointon@wartsila.com"
    End If
         
    If Range("B3") = "Offshore Support Vessel" Then
        vTo = "craig.pointon@wartsila.com"
    End If
        
    If Range("B3") = "Marine" Then
        vTo = "craig.pointon@wartsila.com"
    End If

Only the first and second IFs are mutually exclusive. Another IF encountered later on might undo what they have decided (or run in vain after the decision has already been made). To fix the problem you might consider a structure like this.

    Const MyEmail As String = "craig.pointon@wartsila.com"
    
    With Sheets("Resource Request (Planner)")
        Select Case .Range("D6").Value
            Case "WUK", "WDK", "WNO"
                vCC = MyEmail
        End Select
        
        Select Case .Range("D6").Value
            Case "Oil & Gas", "Offshore Support Vessel", "Marine"
                If vCC <> MyEmail Then vTo = MyEmail
        End Select
    End With

It's a tricky bit of programming and I have no idea if the applied logic is correct, especially the cases when vTo will be blank. My intention is to show that formatting, indenting in particular, makes code easier to read and therefore easier to write, which translates into greater speed and less time spent on trouble shooting.

Note that the declaration of the constant should be done at the top of the module. It has two purposes. (1) to replace half a line with a single word for each occurrence. (2) to be able to effect correction or replacement in a single, prominent location.

Discuss

Answer the Question

You must create an account to use the forum. Create an Account or Login