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

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

主题工作正常，但消息正文和签名不正常。 下面是我的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

求你了，我真的需要你的帮助。

---

非常感谢。

猜猜你在寻找什么（如果你正在使用OUTLOOK）：

Sub-Mail\u every\u工作表（）
将sh设置为工作表
设置Oapp=CreateObject（“outlook.application”）
设置itm=Oapp.createitem（0）
SigString=Environ（“用户名”）&“\Microsoft\Signatures\XXXX.htm”这是保存Outlook签名的位置，您的签名可能与我的路径不同
如果Dir（SigString）“，则
Signt=GetBoiler（SigString）
其他的
Signt=“”
如果结束
Application.ScreenUpdating=False
用于此工作簿中的每个sh。工作表
出错时继续下一步
如果sh.Range（“g1”）.值像“*@*”那么
sh.副本
ActiveWorkbook.SaveAs sh.Name，56
使用itm
.Subject=sh.名称和“数据”
.to=ActiveSheet.Range（“g1”）.值
.cc=“您的抄送电子邮件地址”
.body=“这是正文”&签名
.Attachments.Add（sh.Name和“.xls”）
邮寄
以
Kill ActiveWorkbook.FullName
ActiveWorkbook.Close为False
如果结束
下一个sh
Application.ScreenUpdating=True
Application.DisplayAlert=False
端接头
函数GetBoiler（ByVal sFile作为字符串）作为字符串
作为对象的Dim fso
将T作为对象
设置fso=CreateObject（“Scripting.FileSystemObject”）
设置ts=fso.GetFile（sFile）.OpenAsTextStream（1，-2）
GetBoiler=ts.readall
关闭
端函数

---

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

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

您在代码中从何处定义了电子邮件正文消息和签名？嗨，Alex，我实际上不知道怎么做。你能帮我吗？嗨，下面的答案解决了吗？还是你还缺几块？如果是，它们是什么？谢谢亚历克斯，非常感谢。我对此仍有疑问。也许我需要再问一次这个问题。非常感谢你的帮助，我真的很感激。请再说一遍我的问题。我有几个工作表在一个工作簿中，我也有同等数量的电子邮件地址。我需要将这些工作表发送到电子邮件。我已经成功地完成了附加和发送方面与我的上述代码，剩下的是添加我的outlook签名和邮件正文。Alex的代码显示邮件，没有附件，不会自动发送。（亚历克斯，我感谢你所做的一切，非常感谢）。你能帮忙吗？谢谢。嗨，上面的代码应该会自动发送邮件。我将编辑代码删除。显示和添加。附件到代码soonHi，我已经编辑了代码，现在应该可以正常工作了。此外，如果找不到签名位置，请参见：Windows XP:C:\Documents and Settings\%username%\Application Data\Microsoft\Signatures Windows Vista、Windows 7和Windows 8:C:\Users\%username%\AppData\Roaming\Microsoft\Signatures感谢很多人。这很有帮助。很抱歉反应太晚。我真的很感激。竖起大拇指

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