Excel 发送至A1单元格地址的邮件表-保留格式
有人能就这个问题给我一些建议吗。我从Ron de Bruin网站获得以下代码，可以将多张表格发送到A1单元的电子邮件地址 但是，当收到电子邮件时，它已更改了工作表上的时间格式，即16:00:00更改为0.667 有人知道如何调整它来保持16:00:00吗Excel 发送至A1单元格地址的邮件表-保留格式,excel,vba,Excel,Vba,有人能就这个问题给我一些建议吗。我从Ron de Bruin网站获得以下代码，可以将多张表格发送到A1单元的电子邮件地址 但是，当收到电子邮件时，它已更改了工作表上的时间格式，即16:00:00更改为0.667 有人知道如何调整它来保持16:00:00吗 Option Explicit Sub Mail_Every_Worksheet() 'Working in Excel 2000-2016 'For Tips see: http://www.rondebruin.nl/win/winm
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
选项显式
子邮件\u每个\u工作表（）
“在Excel 2000-2016中工作
“有关提示，请参阅：http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
将sh设置为工作表
将wb设置为工作簿
Dim FileExtStr作为字符串
Dim FileFormatNum尽可能长
Dim TempFilePath作为字符串
将文件名设置为字符串
Dim OutApp作为对象
将邮件变暗为对象
TempFilePath=Environ$（“temp”）&
如果Val（Application.Version）<12，则
“您使用的是Excel 97-2003
FileExtStr=“.xls”：FileFormatNum=-4143
其他的
“您使用的是Excel 2007-2016
FileExtStr=“.xlsm”：FileFormatNum=52
如果结束
应用
.ScreenUpdate=False
.EnableEvents=False
以
Set-OutApp=CreateObject（“Outlook.Application”）
用于此工作簿中的每个sh。工作表
如果sh.Range（“A1”）值类似于“*@*。？*”，则
sh.副本
设置wb=ActiveWorkbook
'将工作表中的所有单元格更改为值
带工作分解表（1）。使用表格
.细胞，复制
.Cells.paste特殊XLPaste值
以
Application.CutCopyMode=False
TempFileName=“Sheet”和sh.Name和“of”_
&此工作簿的名称和格式（现在为“dd-mmm-yy h-mm-ss”）
Set-OutMail=OutApp.CreateItem（0）
与wb
.SaveAs TempFilePath&TempFileName&FileExtStr，FileFormat:=FileFormatNum
出错时继续下一步
发邮件
.To=sh.Range（“A1”）.值
.CC=“”
.BCC=“”
.Subject=“测试”
.Body=“你好”
.Attachments.Add wb.FullName
'您也可以像这样添加其他文件
'.Attachments.Add（“C:\test.txt”）
.Send'或use.Display
以
错误转到0
.Close savechanges:=False
以
发送邮件=无
终止TempFilePath&TempFileName&FileExtStr
如果结束
下一个sh
设置应用程序=无
应用
.ScreenUpdate=True
.EnableEvents=True
以
端接头
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
Public Sub-Mail\u Every\u工作表（）
“在Excel 2000-2016中工作
“有关提示，请参阅：http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
应用
.ScreenUpdate=False
.EnableEvents=False
以
将sh设置为工作表
用于此工作簿中的每个sh。工作表
将电子邮件地址设置为字符串
emailAddress=sh.Range（“A1”）.Value2
如果IsValidEmailAddress（电子邮件地址），则
将文件名设置为字符串
tempFileName=“Sheet”&sh.Name&“of”&thishworkbook.Name&“Format$（现在是“dd-mmm-yy h-mm-ss”）
将一本书作为工作簿
Set tempBook=CreateTempWorkbookFrom（sh，Environ$（“temp”），tempFileName）
Dim tempBookFullPath作为字符串
tempBookFullPath=tempBook.FullName
速记簿，关闭
SendOutlookEmailTo emailAddress、vbNullString、vbNullString、“主题”、“正文”、tempBookFullPath
全路杀戮
如果结束
下一个
应用
.ScreenUpdate=True
.EnableEvents=True
以
端接头
私有函数IsValidEmailAddress（ByVal值为字符串）为布尔值
IsValidEmailAddress=（类似“*@？*.？*”的值）
端函数
专用函数CreateTempWorkbookFrom（ByVal copySheet作为工作表，ByVal tempSavePath作为字符串，ByVal tempFileName作为字符串）作为工作簿
如果右$（tempSavePath，1）Application.PathSeparator，则
tempSavePath=tempSavePath&Application.PathSeparator
如果结束
复印件，复印件
设置CreateTempWorkbookFrom=ActiveWorkbook
使用CreateTempWorkbookFrom.Worksheets（1）.UsedRange
'将工作表中的所有单元格更改为值
.Cells.Value2=.Cells.Value2
以
如果Val（Application.Version）<12，则
CreateTempWorkbookFrom.SaveAs tempSavePath和tempFileName&“.xls”，xlWorkbookNormal
其他的
CreateTempWorkbookFrom.SaveAs tempSavePath和tempFileName&“.xlsm”，xlOpenXMLWorkbookMacroEnabled
如果结束
端函数
私有子SendOutlookEmailTo（ByVal emailAddress作为字符串_
ByVal CC作为字符串_
ByVal BCC作为字符串_
ByVal主语作为字符串_
ByVal主体作为字符串_
ParamArray attachments（）作为变量）
出错时继续下一步
Dim mailItem作为对象“Outlook.mailItem”工具>参考>Microsoft Outlook X.xx对象库
Const OutlookMailItem的长度=0
设置mailItem=CreateObject（“Outlook.Application”）.CreateItem（OutlookMailItem）“Outlook.Application.CreateItem（olMailItem）
带mailItem
.To=电子邮件地址
.CC=CC
.BCC=BCC
.主语
.身体
作为变体的Dim附件
对于附件中的每个附件
。附件。添加附件
下一个
.展示
.发送
以
错误转到0
端接头
范围。可能需要将NumberFormath:mm:ss.Copy.PasteSpecial