Mail every worksheet with address in A1 - not working

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

Code:

---

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

---

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

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

Code:

---

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

---

Quote:

---

Originally Posted by dotchiejack

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.

Quote:

---

Originally Posted by Rob342

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

Code:

---

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

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

Quote:

---

Originally Posted by dotchiejack

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

---

I tried that, nothing happens. :(

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

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

Code:

---

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

---

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

Code:

---

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

---

Thank you, this worked brilliantly! Appreciate it :thumb

Quote:

---

Originally Posted by 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

Code:

---

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

---

---

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