edit body message - and insert a cell value - excel macro

Please could some one edit the code below so the body email will display exactly as below.

Note: *value of cell B2* = value of cell B2 on the active sheet when the macro is run
Note 2: The link in the body email has already been coded so that it is automatically inserted into the body of the email.

Option Explicit

Sub SendEmail()
'///Set up the Excel variables.
    Const MsgSignature As String = "Supplier Relationship Team"
    Const sSubj As String = "Supplier Meeting Action Points"
    Dim rCl As Range, rRng As Range
    Dim OLApp As Object, olMailItm As Object
    Dim iCnt As Integer
    Dim sTo As String, sMsg As String

    '///Create the Outlook application and the empty email.
    Set OLApp = CreateObject("Outlook.Application")
    Set olMailItm = OLApp.CreateItem(0)

'http://path/to/Workbook.xls#SheetName!a1

    sMsg = "Hi,<br><br>" & _
           "Please could you complete the action points found on the supplier meeting report (link below) <br><br>" & _
           "Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column.<br><br>" & _
           "Once completed please click the save & close button at the top of the page.:<br><br>" & _
           "If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet.:<br><br>" & _
           
"Click on the link to open the file :<br><br> " & _
           "<A HREF=""file://" & ActiveWorkbook.FullName & "#" & ActiveSheet.Name & "!a1" & _
           """>Link to the file</A>" & _
           "<br><br>Regards," & _
           "<br><br>" & MsgSignature

    '/// create list of recipients

    Set rRng = Range("B86:B93")

    With olMailItm

        For Each rCl In rRng.Cells
            If rCl.Value > 0 Then
                If sTo = "" Then
                    sTo = rCl.Value
                Else
                    sTo = sTo & ";" & rCl.Value
                End If
                iCnt = iCnt + 1
            End If
        Next rCl

        If iCnt < 2 Then
            MsgBox "You nave not entered any recipients.", vbCritical, MsgSignature
            Exit Sub
        End If

        .To = sTo
        .Subject = sSubj
        .HTMLBody = sMsg
           .Display
'        .Send
    End With

    '///Clean up the Outlook application.
    Set olMailItm = Nothing
    Set OLApp = Nothing
End Sub

Open in new window


Body Message

Hi,

Please could you complete the action points found on the supplier meeting report (link below).

Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column

Once completed please click the save & close button at the top of the page.

If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet

Please open the meeting report using the link below and select the meeting report link called *value of cell B2* found in column E        

Click on the link below to open the file :

This is the link to to the file and will automatically be inserted

Regards,

Supplier Relationship team
Option Explicit

Sub SendEmail()
'///Set up the Excel variables.
    Const MsgSignature As String = "Supplier Relationship Team"
    Const sSubj As String = "Supplier Meeting Action Points"
    Dim rCl As Range, rRng As Range
    Dim OLApp As Object, olMailItm As Object
    Dim iCnt As Integer
    Dim sTo As String, sMsg As String

    '///Create the Outlook application and the empty email.
    Set OLApp = CreateObject("Outlook.Application")
    Set olMailItm = OLApp.CreateItem(0)

'http://path/to/Workbook.xls#SheetName!a1

    sMsg = "Hi,<br><br>" & _
           "Please could you complete the action points found on the supplier meeting report (link below) <br><br>" & _
           "Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column.<br><br>" & _
           "Once completed please click the save & close button at the top of the page.:<br><br>" & _
           "If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet.:<br><br>" & _
cells(2,2).value & _           
"Click on the link to open the file :<br><br> " & _
           "<A HREF=""file://" & ActiveWorkbook.FullName & "#" & ActiveSheet.Name & "!a1" & _
           """>Link to the file</A>" & _
           "<br><br>Regards," & _
           "<br><br>" & MsgSignature

    '/// create list of recipients

    Set rRng = Range("B86:B93")

    With olMailItm

        For Each rCl In rRng.Cells
            If rCl.Value > 0 Then
                If sTo = "" Then
                    sTo = rCl.Value
                Else
                    sTo = sTo & ";" & rCl.Value
                End If
                iCnt = iCnt + 1
            End If
        Next rCl

        If iCnt < 2 Then
            MsgBox "You nave not entered any recipients.", vbCritical, MsgSignature
            Exit Sub
        End If

        .To = sTo
        .Subject = sSubj
        .HTMLBody = sMsg
           .Display
'        .Send
    End With

    '///Clean up the Outlook application.
    Set olMailItm = Nothing
    Set OLApp = Nothing
End Sub

Open in new window

mikes6058Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Saurabh Singh TeotiaCommented:
I'm not sure what you want to do here?? Can you help me connect what you are looking to do here..
gowflowCommented:
Just to understand the 2 piece of code that you posted are the same right ? You posted the second one by mistake ? pls confirm.

gowflow
gowflowCommented:
Is this what you want ?

Sub SendEmail()
On Error GoTo Errhandler

'///Set up the Excel variables.
    Const MsgSignature As String = "Supplier Relationship Team"
    Const sSubj As String = "Supplier Meeting Action Points"
    Dim rCl As Range, rRng As Range
    Dim OLApp As Object, olMailItm As Object
    Dim iCnt As Integer
    Dim sTo As String, sMsg As String

    '///Create the Outlook application and the empty email.
    Set OLApp = CreateObject("Outlook.Application")
    Set olMailItm = OLApp.CreateItem(0)

'http://path/to/Workbook.xls#SheetName!a1

    sMsg = "Hi,<br><br>" _
           & "Please could you complete the action points found on the supplier meeting report (link below) <br><br>" _
           & "Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column.<br><br>" _
           & "Once completed please click the save & close button at the top of the page.:<br><br>" _
           & "If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet.:<br><br>" _
           & "Please open the meeting report using the link below and select the meeting report link called " & Range("B2") & " found in column E<br><br>" _
           & "Click on the link to open the file :<br><br> " _
           & "<A HREF=""file://" & ActiveWorkbook.FullName & "#" & ActiveSheet.Name & "!a1" _
           & """>Link to the file</A>" _
           & "<br><br>Regards," _
           & "<br><br>" & MsgSignature

    '/// create list of recipients

    Set rRng = Range("B86:B93")

    With olMailItm

        For Each rCl In rRng.Cells
            If rCl.Value > 0 Then
                If sTo = "" Then
                    sTo = rCl.Value
                Else
                    sTo = sTo & ";" & rCl.Value
                End If
                iCnt = iCnt + 1
            End If
        Next rCl

        If iCnt < 2 Then
            MsgBox "You nave not entered any recipients.", vbCritical, MsgSignature
            Exit Sub
        End If

        .To = sTo
        .Subject = sSubj
        .HTMLBody = sMsg
           .Display
'        .Send
    End With

    '///Clean up the Outlook application.
    Set olMailItm = Nothing
    Set OLApp = Nothing

Exit Sub

Errhandler:
MsgBox Error(Err)
Resume Next
End Sub

Open in new window



gowflow
mikes6058Author Commented:
Hi Gowglow,

Yes your interpretation of my requirements was correct.

Stupidly I actually inserted the wrong code. Please could you apply exactly the same actions to the revised code below.

Option Explicit

Sub SendEmail()
'///Set up the Excel variables.
    Const MsgSignature As String = "Supplier Relationship Team"
    Const sSubj As String = "Supplier Meeting Action Points"
    Dim rCl As Range, rRng As Range
    Dim OLApp As Object, olMailItm As Object
    Dim iCnt As Integer
    Dim sTo As String, sMsg As String

    '///Create the Outlook application and the empty email.
    Set OLApp = CreateObject("Outlook.Application")
    Set olMailItm = OLApp.CreateItem(0)


    sMsg = "Hi,<br><br>" & _
           "Please could you complete the action points found on the supplier meeting report (link below) <br><br>" & _
           "Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column.<br><br>" & _
           "Once completed please click the save & close button at the top of the page.:<br><br>" & _
           "If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet.:<br><br>" & _
           "Click on the link to open the file :<br><br> " & _
           "<A HREF=""file://" & ActiveWorkbook.FullName & _
           """>Link to the file</A>" & _
           "<br><br>Regards," & _
           "<br><br>" & MsgSignature

    '/// create list of recipients

    Set rRng = Range("B86:B93")

    With olMailItm

        For Each rCl In rRng.Cells
            If rCl.Value > 0 Then
                If sTo = "" Then
                    sTo = rCl.Value
                Else
                    sTo = sTo & ";" & rCl.Value
                End If
                iCnt = iCnt + 1
            End If
        Next rCl

        If iCnt < 2 Then
            MsgBox "You nave not entered any recipients.", vbCritical, MsgSignature
            Exit Sub
        End If

        .To = sTo
        .Subject = sSubj
        .HTMLBody = sMsg
           .Display
'        .Send
    End With

    '///Clean up the Outlook application.
    Set olMailItm = Nothing
    Set OLApp = Nothing
End Sub

Open in new window


Mike
gowflowCommented:
ok here it is

Sub SendEmail()
'///Set up the Excel variables.
    Const MsgSignature As String = "Supplier Relationship Team"
    Const sSubj As String = "Supplier Meeting Action Points"
    Dim rCl As Range, rRng As Range
    Dim OLApp As Object, olMailItm As Object
    Dim iCnt As Integer
    Dim sTo As String, sMsg As String

    '///Create the Outlook application and the empty email.
    Set OLApp = CreateObject("Outlook.Application")
    Set olMailItm = OLApp.CreateItem(0)


    sMsg = "Hi,<br><br>" & _
           "Please could you complete the action points found on the supplier meeting report (link below) <br><br>" & _
           "Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column.<br><br>" & _
           "Once completed please click the save & close button at the top of the page.:<br><br>" & _
           "If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet.:<br><br>" & _
           "Please open the meeting report using the link below and select the meeting report link called " & Range("B2") & " found in column E<br><br>" & _
           "Click on the link to open the file :<br><br> " & _
           "<A HREF=""file://" & ActiveWorkbook.FullName & _
           """>Link to the file</A>" & _
           "<br><br>Regards," & _
           "<br><br>" & MsgSignature

    '/// create list of recipients

    Set rRng = Range("B86:B93")

    With olMailItm

        For Each rCl In rRng.Cells
            If rCl.Value > 0 Then
                If sTo = "" Then
                    sTo = rCl.Value
                Else
                    sTo = sTo & ";" & rCl.Value
                End If
                iCnt = iCnt + 1
            End If
        Next rCl

        If iCnt < 2 Then
            MsgBox "You nave not entered any recipients.", vbCritical, MsgSignature
            Exit Sub
        End If

        .To = sTo
        .Subject = sSubj
        .HTMLBody = sMsg
           .Display
'        .Send
    End With

    '///Clean up the Outlook application.
    Set olMailItm = Nothing
    Set OLApp = Nothing

Exit Sub

Errhandler:
MsgBox Error(Err)
Resume Next

End Sub

Open in new window


gowflow

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.