Mail every worksheet with address in A1 - not working

[leemcder]

Hi I am using the code from rondebruin website, for mailing every worksheet with address in A1, but its doing nothing. When I run the macro, I don't get any errors but nothing at all happens. I have outlook 2013 open and I am using excel 2013. Does anyone have any ideas why it won't work?

Many thank


Sub Mail_Every_Worksheet()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

TempFilePath = Environ$("temp") & ""
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
For Each sh In ThisWorkbook.Worksheets
If sh.Range("A1").Value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = sh.Range("A1").Value
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With

Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

[dotchiejack]

Tested and it works fine.
Are your macro's enabed?

[Rob342]

Try changing this bit of code
without the workbook can not test for faults have you run through the code step by step


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next

[leemcder]

Tested and it works fine.
Are your macro's enabed? Yes macros are enabled, for some reason when I run the macro nothing happens. I don't get any debug error, no mail is created.

[leemcder]

Try changing this bit of code
without the workbook can not test for faults have you run through the code step by step


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
thanks for reply, I tried this but made no difference. I've run other macros today with no issues so I can't see what the issue is with this one. I have the email address in cell A1 on the sheets, I can't figure it out. Frustrating

[dotchiejack]

If you change send in the code with display does something happen?

[leemcder]

If you change send in the code with display does something happen? I tried that, nothing happens. :(

[Rob342]

If the sheets u are coping do not contain macro
change to the file format to xlsx you don’t need the fileformat no
make sure outlook is not open when you are activating the command to send

[Rob342]

have done a test on the file
It looks like its trying to save with a diff format
change this line & change the temp file as not to include the name of your workbook with the macro


TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss") ' it does not like Thisworkbook.Name

[gmayor]

Is the code actually in the workbook you are processing? If not the code will not do anything.
Change the references from ThisWorkbook to ActiveWorkbook.
The TempFilePath should be terminated with a backslash folder separator.
There is no need for the references to old Word version code any longer.
Use the code from the same website you referenced (see below) to open Outlook correctly. You can then more easily address the body of the message and retain the default signature.
The following works


Sub Mail_Every_Worksheet()'Working in Excel 2007-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'to access the body of the e-mail message use the code from
'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to open Outlook
'Graham Mayor - https://www.gmayor.com - Last updated - 25 May 2019
Dim sh As Worksheet
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object


TempFilePath = Environ$("temp") & "\"
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = OutlookApp()
For Each sh In ActiveWorkbook.Worksheets
If sh.Range("A1").value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ActiveWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & ".xlsx", FileFormat:=51
With OutMail
.BodyFormat = 2 'html
.to = sh.Range("A1").value
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor 'access the message body for editing
Set oRng = wdDoc.Range
.Display 'This line is required!
oRng.Collapse 1
oRng.Text = "This is the text of the message" & vbCr & "This is another line of text."
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
'.Send 'Restore after testing
End With
.Close savechanges:=False
End With


Kill TempFilePath & TempFileName & ".xlsx"
End If
Next sh
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

[leemcder]

Thank you, this worked brilliantly! Appreciate it :thumb
Is the code actually in the workbook you are processing? If not the code will not do anything.
Change the references from ThisWorkbook to ActiveWorkbook.
The TempFilePath should be terminated with a backslash folder separator.
There is no need for the references to old Word version code any longer.
Use the code from the same website you referenced (see below) to open Outlook correctly. You can then more easily address the body of the message and retain the default signature.
The following works


Sub Mail_Every_Worksheet()'Working in Excel 2007-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'to access the body of the e-mail message use the code from
'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to open Outlook
'Graham Mayor - https://www.gmayor.com - Last updated - 25 May 2019
Dim sh As Worksheet
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object


TempFilePath = Environ$("temp") & "\"
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = OutlookApp()
For Each sh In ActiveWorkbook.Worksheets
If sh.Range("A1").value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ActiveWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & ".xlsx", FileFormat:=51
With OutMail
.BodyFormat = 2 'html
.to = sh.Range("A1").value
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor 'access the message body for editing
Set oRng = wdDoc.Range
.Display 'This line is required!
oRng.Collapse 1
oRng.Text = "This is the text of the message" & vbCr & "This is another line of text."
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
'.Send 'Restore after testing
End With
.Close savechanges:=False
End With


Kill TempFilePath & TempFileName & ".xlsx"
End If
Next sh
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

[leemcder]

I've a slight problem as I have 150 sheet and there are 12 recipients. I'd like each email address to receive one email with each attachment, rather than 150 different emails going off and people receiving multiple email. Is this possible and what would the coding be? Many thanks