Need help combining 2 vba scripts

pujo

Well-known Member
Joined
Feb 19, 2009
Messages
710
Office Version
  1. 2019
  2. 2013
Platform
  1. Windows
Hey gang,
I am using vba to send my worksheet to outlook as an attachment, it works well. Recently I was asked to have a section of the worksheet in the email body. I tried Mr. Bruins code it it works for putting the portion of the sheet in the body of the email and the attachemnt. I need to combine the two scripts to do both, send as attachemnt, and the portion in the body of the email.I have listed both sets of code and hope that someone could give me a hand putting them together.
Thanks,
Pujo
Attachment Code:
Code:
Private Sub CommandButton2_Click()
    Dim OL As Object
    Dim EmailItem As Object
    Dim Wb As Workbook
    ActiveSheet.Unprotect Password:="xxx"
    Application.ScreenUpdating = False
    Set OL = CreateObject("Outlook.Application")
    Set EmailItem = OL.CreateItem(olMailItem)
    Set Wb = ActiveWorkbook
    Wb.Save
    SigString = "C:\Documents and Settings\" & Environ("username") & _
                "\Application Data\Microsoft\Signatures\*.htm"
    Dim Try As String
    Try = Dir(SigString)
    If Try <> "" Then
    SigString = "C:\Documents and Settings\" & Environ("username") & _
                "\Application Data\Microsoft\Signatures\" & Try
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    With EmailItem
                .Subject = "Daily Crew Activity" & " " & Format(Now, "mmm-dd-yy")
                 strbody = "Good Morning, Please See Attached File."
 
        .To = "[EMAIL="me@me.com"]me@me.com[/EMAIL]"
        .Attachments.Add Wb.FullName
        .HTMLBody = strbody & "" & Signature
        .Display
        '.Send
    End With
 
    Application.ScreenUpdating = True
    Set Wb = Nothing
    Set OL = Nothing
    Set EmailItem = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="xxx"
End With
End Sub

Selection in body code:
Code:
Sub Mail_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
 
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("MailRangeSelection").Range("B19:B24").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
 
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    On Error Resume Next
    With OutMail
        .To = "[EMAIL="ron@debruin.nl"]ron@debruin.nl[/EMAIL]"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        .Display   'or use .Send
    End With
    On Error GoTo 0
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
 
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
In this line, Const HTMLlf As String = "< br/>" , remove the space in "< br/>".
I had to add the space so that HTML code would display in this HTML based forum.

Code:
Private Sub CommandButton2_Click()

    Dim OL As Object
    Dim EmailItem As Object
    Dim Wb As Workbook
[COLOR="Red"]    Dim rng As Range
    Const HTMLlf As String = "< br/>"  [COLOR="Green"]' equals one HTML linefeed[/COLOR][/COLOR]
    
    ActiveSheet.Unprotect Password:="xxx"

    [COLOR="Red"]On Error Resume Next
    Set rng = Sheets("MailRangeSelection").Range("B19:B24").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
 
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        ActiveSheet.Protect Password:="xxx"
        Exit Sub
    End If[/COLOR]
    
    Application.ScreenUpdating = False

    Set OL = CreateObject("Outlook.Application")
    Set EmailItem = OL.CreateItem(olMailItem)
    Set Wb = ActiveWorkbook
    Wb.Save
    SigString = "C:\Documents and Settings\" & Environ("username") & _
                "\Application Data\Microsoft\Signatures\*.htm"
    Dim Try As String
    Try = Dir(SigString)
    If Try <> "" Then
    SigString = "C:\Documents and Settings\" & Environ("username") & _
                "\Application Data\Microsoft\Signatures\" & Try
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    With EmailItem
                .Subject = "Daily Crew Activity" & " " & Format(Now, "mmm-dd-yy")
                 strbody = "Good Morning, Please See Attached File."
 
        .To = "me@me.com"
        .Attachments.Add Wb.FullName
        [COLOR="Red"].HTMLBody = strbody & HTMLlf & RangetoHTML(rng) & HTMLlf & HTMLlf & Signature[/COLOR]
        .Display
        '.Send
    End With
 
    Application.ScreenUpdating = True
    Set Wb = Nothing
    Set OL = Nothing
    Set EmailItem = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="xxx"
End With
End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,224,522
Messages
6,179,297
Members
452,903
Latest member
Knuddeluff

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top