[COLOR=#3366CC]Sub Mail_Every_Worksheet()[/COLOR][COLOR=black]'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm[/COLOR]
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
[COLOR=black]'You use Excel 97-2003[/COLOR]
FileExtStr = ".xls": FileFormatNum = -4143
Else
[COLOR=black]'You use Excel 2007-2013[/COLOR]
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
[COLOR=black]'You can add other files also like this
'.Attachments.Add ("C:\test.txt")[/COLOR]
.Send [COLOR=black]'or use .Display[/COLOR]
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 [COLOR=#3366CC]End Sub[/COLOR]
Code:With Application .ScreenUpdating = True .EnableEvents = True End With [COLOR=#3366CC]End Sub[/COLOR]
I have used and improved on Ron DeBruin's code, but only for CDO. I have not used Outlook, but if you can post what line it fails on while debugging and any errors seen, I can help. Odds are that it is something simple.
I have used and improved on Ron DeBruin's code, but only for CDO. I have not used Outlook, but if you can post what line it fails on while debugging and any errors seen, I can help. Odds are that it is something simple.
And do you really have:
"End With" and "End Sub" on the same line and you don't get a compile error...
[COLOR=#3366CC]Sub Mail_Every_Worksheet()[/COLOR][COLOR=black]'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm[/COLOR]
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
[COLOR=black]'You use Excel 97-2003[/COLOR]
FileExtStr = ".xls": FileFormatNum = -4143
Else
[COLOR=black]'You use Excel 2007-2013[/COLOR]
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
[COLOR=black]'You can add other files also like this
'.Attachments.Add ("C:\test.txt")[/COLOR]
.Send [COLOR=black]'or use .Display[/COLOR]
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
[COLOR=#3366CC]End Sub[/COLOR]