Mailing each worksheet in a Workbook

[Gaura215]

Hello

I have 70-80 worksheets in my workbook, which I need to send to different receipients as an individual workbooks. My codes looks like below:

Sub Mail_Every_Worksheet()
'Working in 2000-2010
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-2010
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("AA65536").Value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Agent:" & sh.Name & " (" & "107" & ") " & "CEVA USA REPORTS FOR " & Format(Now, "mmm-yy")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = sh.Range("AA65536").Value
.CC = ""
.BCC = ""
.Subject = "Testing Automation Script"
.Body = "Hi" _
& "The Following PS 107 Report." _
& "The following are reports for the month of " & Format(Now, "mmm-yy") _
& "I am in charge of the distribution of the PS reports;" _
& "should you have any questions/comments regarding the entries in these reports, please" _
& "contact the station in charge of the shipment in question."
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
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

I have two doubts in this:

Firstly, I am facing the debug error in ".SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum". I am confused why is so.
Secondly, I want the body of the mail like Hi in first line then second line should be like "The Following PS 107 Report." & "The following are reports for the month of " & Format(Now, "mmm-yy") and then leaving the next line blank, it should start a new paragraph as "I am in charge of the distribution of the PS reports; should you have any questions/comments regarding the entries in these reports, please contact the station in charge of the shipment in question."

Please someone help.

 

[Comfy]

The SaveAs Error may be due to the folder location not existing.
You will need to check this and create it if it doesn't.

You could try appending vbCrLf or Chr(13) & Chr(10) but I can't test as I use Groupwise email client.

Edit:

'// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'// Procedure : CreateFolder | Sub
'// Author    : DarkSprout
'// Purpose   : Will Recursively Build ADirectory Tree
'// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub CreateFolder(Folder)
On Error Resume Next
Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Folder <> "" Then
        If Not objFSO.FileExists(objFSO.GetParentFolderName(Folder)) Then
            Call CreateFolder(objFSO.GetParentFolderName(Folder))
        End If
        objFSO.CreateFolder (Folder)
    End If
End Sub

 

[Gaura215]

The folder does exist, I changed the path to TempFilePath = "D:\Documents and Settings\g.khanna\Desktop\Temp\", which is definately existing, but still having the debug error at the same place, i.e tempfilename

 

[Gaura215]

And to my surprise, it works fine if I change the temp file name to
TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")