Send Every Sheet in Workbook as Attachment to different Recipient

[Oprichnick]

Hello,
I'm trying to build a code that sends each sheet in another workbook as an attachment via outlook.
Each sheet to a different set of emails.

Although I don't get any error message, the emails aren't sent.
With my few vba knowledge I tried to work pieces of code I found. So I guess that some code is not written in the more orthodox way.

Option ExplicitSub RunOnAll()
Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        Mail_small_Text_Outlook ws
    Next ws
End Sub


Sub Mail_small_Text_Outlook(ws As Worksheet)
Dim OutApp As Object
Dim OutMail As Object
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    On Error GoTo cleanup
    
   With Workbooks("DLQ.xls")
    For Each ws In .Sheets
        If ws = "peter" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            
            With OutMail
                .To = "pedrodomingosdavid@hotmail.com"
                .Subject = "Personal report"
                .Body = "Regards."
                .Attachments.Add Sheets("peter").Copy
                
                .Display
            End With
        ElseIf ws = "john" Then


            Set OutMail = OutApp.CreateItem(0)
            
            With OutMail
                .To = "pedrodomingosdavid@hotmail.com"
                .Subject = "Personal report"
                .Body = "Regards."
                .Attachments.Add Sheets("john").Copy
                .Display
            End With
        End If
        Next ws
    End With


cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub

Thanks

 

[Perpa]

Option ExplicitSub RunOnAll()
Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        [COLOR=#ff0000]Mail_small_Text_Outlook ws[/COLOR]
    Next ws
End Sub


Sub Mail_small_Text_Outlook(ws As Worksheet)
Dim OutApp As Object
Dim OutMail As Object
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    On Error GoTo cleanup
    
   With Workbooks[COLOR=#ff0000]("DLQ.xls")[/COLOR]
    For Each ws In .Sheets
        If ws = "peter" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            
            With OutMail
                .To = "pedrodomingosdavid@hotmail.com"
                .Subject = "Personal report"
                .Body = "Regards."
                .Attachments.Add [COLOR=#ff0000]Sheets("peter").Copy[/COLOR]
                
                [COLOR=#ff0000].Display[/COLOR]
            End With
        ElseIf ws = "john" Then

            Set OutMail = OutApp.CreateItem(0)
            
            With OutMail
                .To = "pedrodomingosdavid@hotmail.com"
                .Subject = "Personal report"
                .Body = "Regards."
                .Attachments.Add [COLOR=#ff0000]Sheets("john").Copy[/COLOR]
                [COLOR=#ff0000].Display[/COLOR]
            End With
        End If
        Next ws
    End With

cleanup:
    [COLOR=#ff0000]Set OutApp = Nothing[/COLOR]
    Application.ScreenUpdating = True
    
End Sub

Thanks

Oprichnick,
I assume this code was placed in another workbook, (macro enabled) because your code refers to 'With Workbooks("DLQ.xls")' which is not macro enabled (xlsm).

Your CALL for 'Mail_small_Text_Outlook ws' should probably be 'Mail_small_Text_Outlook(ws)' with the parentheses.

In the CLEANUP portion you need to add 'Set OutMail = Nothing' as well as 'Set OutApp = Nothing' you already have.

The 'Attachment' - Check out the following link...it describes what can be an attachment:
https://www2.mmu.ac.uk/media/mmuacu...services/help-guides/Email-07-Attachments.pdf
You will probably have to convert each ws to a separate file, ie. xls, pdf, or jpg before it can become an attachment.

You need to change '.Display' to '.Send' when you are ready to send your email.
I hope this helps.
Perpa

 

[igold]

Hi Oprichnick,

You do not say what version of Excel you are using. I don't understand what you are accomplishing with the "RunOnall()" sub, it seem to create an endless loop for the sub that it calls. See if this does what you want. The credit for the code goes to RDB, I have only altered it to suit your assumed needs. You may have to edit it further such as naming the attachment (in red) to something that suits you.

Sub Mail_small_Text_Outlook()


    Dim Destwb As Workbook, Sourcewb As Workbook
    Dim ws As Worksheet
    Dim OutApp As Object
    Dim OutMail As Object
    Dim FileExtStr As String, TempFilePath As String, TempFileName As String
    Dim FileFormatNum As Long
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


   With Workbooks("DLQ.xls")
        For Each ws In .Sheets
            If ws.Name = "peter" Then
                Set Sourcewb = ActiveWorkbook
                'Copy the ActiveSheet to a new workbook
                ActiveSheet.Copy
                Set Destwb = ActiveWorkbook
                With Destwb
                    FileExtStr = ".xls": FileFormatNum = 56
                End With
                'Save the new workbook/Mail it/Delete it
                TempFilePath = Environ$("temp") & "\"
               [COLOR=#ff0000] TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")[/COLOR]
                Set OutApp = CreateObject("Outlook.Application")
                Set OutMail = OutApp.CreateItem(0)
                With Destwb
                    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
                    On Error Resume Next
                    With OutMail
                        .to = "pedrodomingosdavid@hotmail.com"
                        .Subject = "Personal report"
                        .Body = "Regards."
                        .Attachments.Add Destwb.FullName
                        .display
                    End With
                    'Delete the file you have send
                    On Error GoTo 0
                    .Close savechanges:=False
                    Kill TempFilePath & TempFileName & FileExtStr
                End With
            ElseIf ws.Name = "john" Then
                Set Sourcewb = ActiveWorkbook
                'Copy the ActiveSheet to a new workbook
                ActiveSheet.Copy
                Set Destwb = ActiveWorkbook
                With Destwb
                    FileExtStr = ".xls": FileFormatNum = 56
                End With
                'Save the new workbook/Mail it/Delete it
                TempFilePath = Environ$("temp") & "\"
                [COLOR=#ff0000]TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")[/COLOR]
                Set OutApp = CreateObject("Outlook.Application")
                Set OutMail = OutApp.CreateItem(0)
                With Destwb
                    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
                    On Error Resume Next
                    With OutMail
                        .to = "pedrodomingosdavid@hotmail.com"
                        .Subject = "Personal report"
                        .Body = "Regards."
                        .Attachments.Add Destwb.FullName
                        .display
                    End With
                    'Delete the file you have send
                    On Error GoTo 0
                    .Close savechanges:=False
                    Kill TempFilePath & TempFileName & FileExtStr
                End With
            End If
        Next ws
    End With
cleanup:
    Set OutMail = Nothing
    Set OutApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
End Sub

I hope this helps...

 

[Oprichnick]

Hello,
I forgot to mention that I'm using Office 2010.

With both your replies I'm now able to make this happen. However there is still one problem I cannot overcome:
Because emails were not being sent I turned .display on and I realized that I have to tab from "TO" to "CC" or just put the mouse pointer in "TO" and then in "CC".

If I don't do this... the adress is not recognized.

 

[Perpa]

Hello,
I forgot to mention that I'm using Office 2010.
With both your replies I'm now able to make this happen. However there is still one problem I cannot overcome:
Because emails were not being sent I turned .display on and I realized that I have to tab from "TO" to "CC" or just put the mouse pointer in "TO" and then in "CC".
If I don't do this... the adress is not recognized.

Oprichnick,
Neither of the code listings above show the 'CC' you mentioned in your last post.
You might try the following and see if that solves your 'CC' issue.
Perpa

With OutMail
    .To = "pedrodomingosdavid@hotmail.com"
    [COLOR=#ff0000].CC= ""[/COLOR]
    .Subject = "Personal report"
    .Body = "Regards."
    .Attachments.Add Destwb.FullName
    [COLOR=#ff0000].Send[/COLOR]
End With

 

[igold]

@Oprichnick,

I do not understand you Post #5. The address was recognized on my Excel 2010 machine. Change .Display to .Send and you should not have to touch a thing...

 

[Oprichnick]

Hy, yesterday this issue was happening, but somehow today it works perfectly with .send or .display.
Strange... but all good now.

Thank you both

 

[igold]

Happy to help. I hope it keeps working! Thanks for the feedback.