How to send all sheets from the same workbook separately in one email

[cdejan70]

I need help to modify this macro to send all sheets from the same workbook separately in one email.

Sub SendemailAll()
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim tempFile As String
Dim strbodymsg As String
Dim wb As Workbook
Dim strbody As String
Dim tempWB As Workbook
Dim DisplayEmail As String, Signature As String
Dim a, b, c, d As String

Application.DisplayAlerts = False
ThisWorkbook.Sheets.Copy
Set tempWB = ActiveWorkbook



tempWB.SaveAs Filename:="All sheets"
'problem how to separate save all sheets
'variable from userform or string outputs into default documents folder as xls

'Create Outlook email=============
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
End With
Signature = xEmailObj.Body
On Error Resume Next



    With xEmailObj
    a = ThisWorkbook.Sheets("Sheet1").Range("R1").Value
    b = ThisWorkbook.Sheets("Sheet1").Range("R2").Value
    c = ThisWorkbook.Sheets("Sheet1").Range("R3").Value
    d = ThisWorkbook.Sheets("Sheet1").Range("R4").Value
    
        .Display
        .To = a
        .CC = b
        .Subject = c
        .Attachments.Add tempWB.FullName
        
'previously saved workbook with single sheet
    .Body = d & Signature
    If DisplayEmail = False Then
        '.Display
        '.Send
    End If
End With

tempWB.ChangeFileAccess Mode:=xlReadOnly
Kill tempWB.FullName
tempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
Set xEmailObj = Nothing
Set xOutlookObj = Nothing
End Sub

 

[Herakles]

Do you want each sheet to be as an attachment to the emails? If so then you will need to put each sheet into a seperate workbook
and attach the workbook.

 

[Fluff]

Welcome to the MrExcel Message Board!

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: How to send all sheets from the same workbook separately in one email - OzGrid Free Excel/VBA Help Forum
There is no need to repeat the link(s) provided above but if you have posted the question at other places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

 

[cdejan70]

Do you want each sheet to be as an attachment to the emails? If so then you will need to put each sheet into a seperate workbook
and attach the workbook.

Thanks for the reply, I'll try to do that

 

[AC PORTA VIA]

try this

Sub Email_all_sheets_separately()

Dim Sht As Worksheet
  Dim ThisSht As Worksheet
 
  Set ThisSht = ActiveSheet
 
  For Each Sht In ThisWorkbook.Worksheets
    Sht.Activate
 Dim oApp As Object
   Dim oMail As Object
   Dim LWorkbook As Workbook
   Dim LFileName As String

   Application.ScreenUpdating = False

   ActiveSheet.Copy
   Set LWorkbook = ActiveWorkbook

   LFileName = LWorkbook.Worksheets(1).Name
  
   On Error Resume Next

   Kill LFileName

   Application.DisplayAlerts = False
   LWorkbook.SaveAs Filename:=LFileName

   Set oApp = CreateObject("Outlook.Application")
   Set oMail = oApp.CreateItem(0)
 
   With oMail
    a = ThisWorkbook.Sheets("Sheet1").Range("R1").Value
    b = ThisWorkbook.Sheets("Sheet1").Range("R2").Value
    c = ThisWorkbook.Sheets("Sheet1").Range("R3").Value
    d = ThisWorkbook.Sheets("Sheet1").Range("R4").Value
        .To = a
        .CC = b
        .Subject = c
.Body = d & Signature
.Attachments.Add Wb2.FullName
      .Attachments.Add LWorkbook.FullName
      .send
      '.display
   End With

   LWorkbook.ChangeFileAccess Mode:=xlReadOnly
   Kill LWorkbook.FullName
   LWorkbook.Close SaveChanges:=False

   Set oMail = Nothing
   Set oApp = Nothing
    Next Sht
 ThisSht.Activate
 
   Set ThisSht = Nothing
Application.ScreenUpdating = True
End Sub

 

[breynolds0431]

How about this. The only issue is with the temp files. They can't be deleted if .Display is being used on the email as they would still need to exists before the email is sent. So, the below method will delete the temp file at the beginning each time the code is run.

Sub SendSheets()

Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet, tWB As Workbook, tWS As Worksheet
Dim oApp As Outlook.Application: Set oApp = CreateObject("Outlook.Application")
Dim oMail As Outlook.MailItem: Set oMail = oApp.CreateItem(olMailItem)
Dim tPath As String: tPath = wb.Path & "\newtemp"
Dim fName As Variant, Signature As String

'Deletes temp folder if it exists and recreates to start a new one
If Not IsDir(tPath) Then
    MkDir (tPath)
Else
    Kill tPath & "\*.*"
    RmDir (tPath)
    MkDir (tPath)
End If

'loops through all worksheets and individually saves them to temp folder
For Each ws In ThisWorkbook.Sheets
    Application.DisplayAlerts = False
    ws.Copy
    Set tWB = ActiveWorkbook
    tWB.SaveAs tPath & "\temp" & Format(Now, "mmddyy_hhmmss") & ".xlsx"
    tWB.Close
    Application.DisplayAlerts = True
Next ws

'should look into GetBoiler function to insert default signature to avoid
'opening a new oMail to grab. See source website in below function for 
'complete info.
With oMail
    .Display
End With

Signature = oMail.Body

'here is the get boiler route as an FYI
'    'Change only Mysig.htm to the name of your signature
'    SigString = Environ("appdata") & _
'                "\Microsoft\Signatures\Mysig.htm"
'
'    If Dir(SigString) <> "" Then
'        Signature = GetBoiler(SigString)
'    Else
'        Signature = ""
'    End If

'Creates email without numerous string variables
With oMail
    .To = wb.Sheets("Sheet1").Range("R1").Value
    .CC = wb.Sheets("Sheet1").Range("R2").Value
    .Subject = wb.Sheets("Sheet1").Range("R3").Value
    .Body = wb.Sheets("Sheet1").Range("R4").Value & Signature
    'loops through temp folder and attaches all xls files
    fName = Dir(tPath & "\*xls*")
    Do While Len(fName) > 0
        .Attachments.Add tPath & "\" & fName
        fName = Dir
    Loop
    .Display
End With

Set oMail = Nothing
Set oApp = Nothing

End Sub

Public Function IsDir(s) As Boolean
    IsDir = CreateObject("Scripting.FileSystemObject").FolderExists(s)
End Function

Function GetBoiler(ByVal sFile As String) As String
'Source: https://www.rondebruin.nl/win/s1/outlook/signature.htm
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

 

[cdejan70]

I had hidden files that were causing the problem and they must exist. I reworked the program so it now looks like this.
Thank you very much for your help.

Sub Sendemail()
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim tempFile As String
Dim strbodymsg As String
Dim wb As Workbook
Dim strbody As String
Dim tempFiles()
Dim DisplayEmail As String, Signature As String
Dim a, b, c, d As String

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

ReDim tempFiles(1 To ThisWorkbook.Worksheets.Count)
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then

'ws.Select
ws.Copy

With ActiveWorkbook
Dim counter As Long
.SaveAs ThisWorkbook.Path & Application.PathSeparator & ws.Name, FileFormat:=51
counter = counter + 1
tempFiles(counter) = .FullName
.Close SaveChanges:=False
End With
End If
Next ws



'Create Outlook email=============
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
End With
Signature = xEmailObj.Body
On Error Resume Next

With xEmailObj
a = ThisWorkbook.Sheets("pom").Range("R1").Value
b = ThisWorkbook.Sheets("pom").Range("R2").Value
c = ThisWorkbook.Sheets("pom").Range("R3").Value
d = ThisWorkbook.Sheets("pom").Range("R4").Value

.Display
.To = a
.CC = b
.Subject = c
Dim n As Long
For n = LBound(tempFiles) To UBound(tempFiles)

.Attachments.Add tempFiles(n)
Kill tempFiles(n)
Next n
'previously saved workbook with single sheet
.Body = d & Signature
If DisplayEmail = False Then
.Display
'.Send
End If
End With

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
Set xEmailObj = Nothi


End Sub

 

[RoryA]

Also cross-posted here:

Excel Forum

How to send all sheets from the same workbook separately in one email

www.myonlinetraininghub.com

Please take a minute to read the forum rules and follow them in future.