将工作簿中的不同工作表发送到不同的电子邮件+带有Outlook签名的CC

我在工作簿中的每个工作表上都有一段电子邮件，我希望将工作表的主体，邮件正文和签名发送到工作表上的电子邮件地址。

主题工作正常，但消息和签名的身体没有。 以下是我的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 

请，我真的需要你的帮助。 非常感谢。

Answer 1

猜猜这是你在找什么（如果你正在使用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 

我不确定是否需要附件，并且如果每次find要发送的电子邮件时都需要使用不同的名称保存工作簿

Answer 2

如果Alex的答案不适合你，那么一个不太好的解决scheme就是使用工作簿logging一个macros，然后做你正在做的事情。 查看macros的vba代码，并进行必要的调整以使其自动化。