Macro to display emails

[howard]

I have the folowing code below and have to select "allow" before sending the emails.

The code allows me to email each of the sheets to a recvipient address in cell A1 on each of the sheets


I would like to be able to view the emails be clicking send on Outlook

It would be appreciated if someone could please assist me in amending the code

 Sub mailWorksheets()                              


Application.ScreenUpdating = False               'freeze display for speedup

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For Each w In ThisWorkbook.Worksheets       'loop through all sheets
If w.[a1].Value Like "*@*" Then                   'check for email address in cell [A1]
w.Copy                                                       'copy worksheet to new workbook

ActiveWorkbook.SaveAs "Sheet " & w.Name & " of " & ThisWorkbook.Name & ".xls"
zSendTo = ActiveSheet.[a1].Value                 'email recipient
zSubject = "Sales  Comm File"                   '<-edit subject line here as required
ActiveWorkbook.SendMail zSendTo, zSubject   'send email to recipient

ActiveWorkbook.ChangeFileAccess xlReadOnly  'change workbook to read-only for deletion
Kill ActiveWorkbook.FullName                         'delete saved copy of temporary workbook
ActiveWorkbook.Close False                            'close temporary workwook

End If                                                          'end of test for email address in cell [A1]
Next w                                                         'process next worksheet
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Application.ScreenUpdating = True           'refresh display

End Sub

 

[BarryL]

hi howard,

try the below, untested

Sub mail()
Dim OutApp As Object
Dim OutMail As Object
On Error Resume Next
Application.ScreenUpdating = False               'freeze display for speedup
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For Each w In ThisWorkbook.Worksheets       'loop through all sheets
If w.[a1].Value Like "*@*" Then                   'check for email address in cell [A1]
w.Copy                                                       'copy worksheet to new workbook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
 
ActiveWorkbook.SaveAs "Sheet " & w.Name & " of " & ThisWorkbook.Name & ".xls"
zworkbook = ActiveWorkbook.FullName
zsendto = ActiveSheet.[a1].Value                 'email recipient
zsubject = "Sales  Comm File"                   '<-edit subject line here as required
With OutMail
        .to = zsendto
        .CC = ""
        .BCC = ""
        .Subject = zsubject
        .Attachments.Add zworkbook.FullName
        .Display
        
    Set OutMail = Nothing
    Set OutApp = Nothing
End With
ActiveWorkbook.ChangeFileAccess xlReadOnly  'change workbook to read-only for deletion
Kill ActiveWorkbook.FullName                         'delete saved copy of temporary workbook
ActiveWorkbook.Close False                            'close temporary workwook
End If                                                          'end of test for email address in cell [A1]
Next w                                                         'process next worksheet
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Application.ScreenUpdating = True           'refresh display
End Sub

 

[howard]

Thanks for the help, Barry

The respect sheets are no longer attached as per my original code

It would be appreciated if you could amend this so that the sheet containing the email address is attached to the applicable recipient