Change existing code to attach range of cells to email

B

bh24524

Active Member
Joined
Dec 11, 2008
Messages
365
Office Version
  1. 365
  2. 2007
Hello, I have a code someone helped me with which will save a copy of a template of information as a new file name in a specific folder and then attach that file to an email. I'm looking to make a slight change: Instead of attaching the newly named file to the email, I'd really like to just copy a set range of cells from the file and have that go into the body of the email. The code I currently have is as follows:

VBA Code: 
Sub SaveEmailSheet()
    Dim Name As String
    Dim VacFile As Workbook 'This will be VACATION CHANGES File
    Dim NamedVacFile As Workbook 'This will be the file Vacation Changes data gets pasted to
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    ActiveWorkbook.Save
    
    Set VacFile = Workbooks("VACATION CHANGES.xlsm") 'Defining the Dim VacFile Variable
    VacFile.Worksheets("VACATION").Range("A1:AC26").Copy 'Copying data from Vacation changes file
    Set NamedVacFile = Workbooks.Add 'Creating a new workbook
    NamedVacFile.ActiveSheet.Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
          SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste 'Pasting data from Vacation Changes to this file
    ActiveWindow.DisplayGridlines = False
    Range("A1").Select
    
    Name = "\\specific folder locations\" & _
        Range("E12").Value & " " & Format(Range("A2").Value, "mm-dd-yy") & " To " & Format(Range("A3").Value, "mm-dd-yy") & ".xlsx"
    'Defnining the Name as String variable and telling it where we want it to save a file and what name we want to give it
    
    NamedVacFile.SaveAs Filename:=Name, FileFormat:=51 'Saving our new workbook as the specified name and in the specified folder
    EmailForm 'Calling our EmailForm subprocedure to email a copy of the newly named file
    ActiveWorkbook.Close
    VacFile.Activate 'Close the newly named file and return to the Vacation Changes template
    
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
End Sub


Sub EmailForm()
ActiveWorkbook.Save
Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next

    With OutMail
        .Display
        .HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri>" & ".<br>" & "</BODY>" & .HTMLBody       '<-- enter message body here"
        .Attachments.Add Application.ActiveWorkbook.FullName
        .To = "emails entered here"       
        .CC = "CC emails entered here"
        .BCC = ""
        .Subject = "Vacation Change " & Range("E12").Value  '<-- enter subject here
        .Body = "Please see the attached vacation change for " & Range("E12").Value      '<-- enter message body here
        '.Display 'or use .Send
    End With



On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

    
End Sub

So the range that I would want in the body of the email is always the same: D10:G26

How might I integrate this into the code and replace the attachment with that?
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
I would have looked for an answer to this on Ron DeBruin's site, but how-to information has unfortunately been taken down from there. Anyone maybe know a solution for this?
 
Upvote 0
I found it! I did some tweaking to an old template I saved and I can't believe I actually got it figured out but here is what I came up with:

VBA Code: 
Sub EmailForm()
ActiveWorkbook.Save
Range("D10:G26").Select
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
Set rng = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
    If rng Is Nothing Then
        MsgBox "Not a range or protected sheet" & _
               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
        .Display
        .htmlbody = "<BODY style=font-size:11pt;font-family:Calibri>" & "Please see the below vacation change. <br>" & "</BODY>" & RangetoHTML(rng) & .htmlbody       '<-- enter message body here"
        .To = ""        '<-- enter email addresses here. Multiple emails separate by semi-colon"
        .CC = ""
        .BCC = ""
        .Subject = "Vacation Change " & Range("E12").Value  '<-- enter subject here
        '.Display 'or use .Send
    End With



On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
SaveEmailSheet
    
End Sub
Function RangetoHTML(rng As Range)
    Dim obj As Object
    Dim txtstr As Object
    Dim File As String
    Dim WB As Workbook
    File = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set WB = Workbooks.Add(1)
    With WB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With WB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=File, _
         Sheet:=WB.Sheets(1).Name, _
         Source:=WB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set obj = CreateObject("Scripting.FileSystemObject")
    Set txtstr = obj.GetFile(File).OpenAsTextStream(1, -2)
    RangetoHTML = txtstr.ReadAll
    txtstr.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    WB.Close savechanges:=False
    Kill File
    Set txtstr = Nothing
    Set obj = Nothing
    Set WB = Nothing
    
    ActiveWorkbook.Save
End Function

    Sub SaveEmailSheet()
        Dim Name As String
        Dim VacFile As Workbook 'This will be VACATION CHANGES File
        Dim NamedVacFile As Workbook 'This will be the file Vacation Changes data gets pasted to
   
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
            .DisplayAlerts = False
        End With
        
        ActiveWorkbook.Save
        
        Set VacFile = Workbooks("VACATION CHANGES.xlsm") 'Defining the Dim VacFile Variable
        VacFile.Worksheets("VACATION").Range("A1:AC26").Copy 'Copying data from Vacation changes file
        Set NamedVacFile = Workbooks.Add 'Creating a new workbook
        NamedVacFile.ActiveSheet.Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
              SkipBlanks:=False, Transpose:=False
        ActiveSheet.Paste 'Pasting data from Vacation Changes to this file
        ActiveWindow.DisplayGridlines = False
        Range("A1").Select
        
        Name = "sample pathway" & _
            Range("E12").Value & " " & Format(Range("A2").Value, "mm-dd-yy") & " To " & Format(Range("A3").Value, "mm-dd-yy") & ".xlsx"
       'Defnining the Name as String variable and telling it where we want it to save a file and what name we want to give it
        
        NamedVacFile.SaveAs Filename:=Name, FileFormat:=51 'Saving our new workbook as the specified name and in the specified folder
        
        ActiveWorkbook.Close
        VacFile.Activate 'Close the newly named file and return to the Vacation Changes template
        
        
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
            .DisplayAlerts = True
        End With
        
    End Sub
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

J
  • Question Question
Send bulk email attachment error
Replies
3
Views
114
JOHATUP
J
A
  • Question Question
Add Outlook "Confidential" Sensitivity Label
Replies
2
Views
212
Aviles
A
B
  • Solved
VBA to email recipient if column cells contain value
Replies
6
Views
582
bh24524
B
C
  • Question Question
VBA to save file to SharePoint and attach to outlook template saved in SharePoint
Replies
6
Views
282
Chris8630
C
J
  • Question Question
VBA to send multiple emails with multiple attachments
Replies
5
Views
756
6StringJazzer
6StringJazzer

Forum statistics

Threads
1,224,820
Messages
6,181,161
Members
453,021
Latest member
Justyna P

Share this page

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