Mail sheets to address in cell A1 - keeping format - excel

Question

Please can someone advise me on this issue. I have the below code from Ron de Bruin site to send multiple sheets to email addresses in cell A1.
However when the email is received it has changed the format of the times on the sheets i.e 16:00:00 changed to 0.666666667
can anyone see how it can be adapted to keep the 16:00:00?
Option Explicit
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
'Change all cells in the worksheet to values
With wb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
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 = "TEST"
.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

Answer 1

I got nerd sniped by your question and refactored your code.
Public Sub Mail_Every_Worksheet()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim sh As Worksheet
For Each sh In ThisWorkbook.Worksheets
Dim emailAddress As String
emailAddress = sh.Range("A1").Value2
If IsValidEmailAddress(emailAddress) Then
Dim tempFileName As String
tempFileName = "Sheet " & sh.Name & " of " & ThisWorkbook.Name & " " & Format$(Now, "dd-mmm-yy h-mm-ss")
Dim tempBook As Workbook
Set tempBook = CreateTempWorkbookFrom(sh, Environ$("temp"), tempFileName)
Dim tempBookFullPath As String
tempBookFullPath = tempBook.FullName
tempBook.Close
SendOutlookEmailTo emailAddress, vbNullString, vbNullString, "Subject", "Body", tempBookFullPath
Kill tempBookFullPath
End If
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Function IsValidEmailAddress(ByVal value As String) As Boolean
IsValidEmailAddress = (value Like "?*#?*.?*")
End Function
Private Function CreateTempWorkbookFrom(ByVal copySheet As Worksheet, ByVal tempSavePath As String, ByVal tempFileName As String) As Workbook
If Right$(tempSavePath, 1) <> Application.PathSeparator Then
tempSavePath = tempSavePath & Application.PathSeparator
End If
copySheet.Copy
Set CreateTempWorkbookFrom = ActiveWorkbook
With CreateTempWorkbookFrom.Worksheets(1).UsedRange
'Change all cells in the worksheet to values
.Cells.Value2 = .Cells.Value2
End With
If Val(Application.Version) < 12 Then
CreateTempWorkbookFrom.SaveAs tempSavePath & tempFileName & ".xls", xlWorkbookNormal
Else
CreateTempWorkbookFrom.SaveAs tempSavePath & tempFileName & ".xlsm", xlOpenXMLWorkbookMacroEnabled
End If
End Function
Private Sub SendOutlookEmailTo(ByVal emailAddress As String, _
ByVal CC As String, _
ByVal BCC As String, _
ByVal Subject As String, _
ByVal Body As String, _
ParamArray attachments() As Variant)
On Error Resume Next
Dim mailItem As Object 'Outlook.mailItem 'Tools>References>Microsoft Outlook X.xx Object Library
Const OutlookMailItem As Long = 0
Set mailItem = CreateObject("Outlook.Application").CreateItem(OutlookMailItem) ' Outlook.Application.CreateItem(olMailItem)
With mailItem
.To = emailAddress
.CC = CC
.BCC = BCC
.Subject = Subject
.Body = Body
Dim attachment As Variant
For Each attachment In attachments
.attachments.Add attachment
Next
.Display
.Send
End With
On Error GoTo 0
End Sub