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

Question

我在工作簿中的每个工作表上都有一系列电子邮件，我想将带有主题、邮件正文和签名的工作表发送到工作表上的电子邮件地址。

主题工作正常，但邮件正文和签名不正常。下面是我的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") & "MicrosoftSignaturesXXXX.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

我不确定你是否需要附件，是否每次发现要发送的电子邮件时都需要用不同的名称保存工作簿

Answer 2

如果Alex的答案对你不起作用，一个不那么优雅的解决方案是使用工作簿记录宏并执行你试图执行的操作。查看宏的vba代码并进行必要的调整以使其自动化。