我在工作簿中的每个工作表上都收到了大量电子邮件,我想将工作表与主题,邮件正文和签名的正文一起发送到工作表上的电子邮件地址。
主题工作正常,但邮件和签名的正文却没有。 以下是我的VBA代码。 拜托,我真的需要你的帮助。 非常感谢。
Sub Mail_every_Worksheet()
Dim sh As Worksheet
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
On Error Resume Next
If sh.Range("g1").Value Like "*@*" Then
sh.Copy
ActiveWorkbook.SaveAs sh.Name, 56
ActiveWorkbook.SendMail ActiveSheet.Range("g1").Value, _
sh.Name & " Data"
Kill ActiveWorkbook.FullName
ActiveWorkbook.Close False
End If
Next sh
Application.ScreenUpdating = True
Application.DisplayAlert = False
End Sub
拜托,我真的需要你的帮助。 非常感谢。
答案 0 :(得分:0)
猜猜你在寻找什么(如果你正在使用OUTLOOK):
Sub Mail_every_Worksheet()
Dim sh As Worksheet
Set Oapp = CreateObject("outlook.application")
Set itm = Oapp.createitem(0)
SigString = Environ("username") & "\Microsoft\Signatures\XXXX.htm" ' this is where your Outlook signture being saved, yours might be different from my path
If Dir(SigString) <> "" Then
Signt = GetBoiler(SigString)
Else
Signt = ""
End If
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
On Error Resume Next
If sh.Range("g1").Value Like "*@*" Then
sh.Copy
ActiveWorkbook.SaveAs sh.Name, 56
With itm
.Subject = sh.Name & " Data"
.to = ActiveSheet.Range("g1").Value
.cc = "your cc email address"
.body = "here is the body" & Signt
.Attachments.Add (sh.Name & ".xls")
.send
End With
Kill ActiveWorkbook.FullName
ActiveWorkbook.Close False
End If
Next sh
Application.ScreenUpdating = True
Application.DisplayAlert = False
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
我不确定您是否需要附件,并且每次发现要发送的电子邮件时都需要使用其他名称保存工作簿
答案 1 :(得分:0)
如果Alex的答案对你不起作用,那么一个不那么优雅的解决方案就是使用工作簿录制宏并按照你要做的去做。查看宏的vba代码并进行必要的调整以使其自动化。