Add signature to VBA for auto email tabs

[lost_in_the_sauce]

I'm currently using the following VBA code I found on the net for a workbook I have that requires each tab to be sent to a different recipient in Outlook - each tab has an email address in cell B5. It there a way to add my signature to the email as well? It generates 40+ emails and I'd like to speed the process up

Sub Mail_Every_Worksheet()
'Updateby ExtendOffice
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xFileExt As String
Dim xFileFormatNum As Long
Dim xTempFilePath As String
Dim xFileName As String
Dim xOlApp As Object
Dim xMailObj As Object
On Error Resume Next
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
xTempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
xFileExt = ".xls": xFileFormatNum = -4143
Else
xFileExt = ".xlsm": xFileFormatNum = 52
End If
Set xOlApp = CreateObject("Outlook.Application")
For Each xWs In ThisWorkbook.Worksheets
If xWs.Range("B5").Value Like "?*@?*.?*" Then
xWs.Copy
Set xWb = ActiveWorkbook
xFileName = xWs.Name & " of " _
& VBA.Left(ThisWorkbook.Name, VBA.InStr(ThisWorkbook.Name, ".") - 1) & " "
Set xMailObj = xOlApp.CreateItem(0)
xWb.Sheets.Item(1).Range("B5").Value = ""
With xWb
.SaveAs xTempFilePath & xFileName & xFileExt, FileFormat:=xFileFormatNum
With xMailObj
'specify the CC, BCC, Subject, Body below
.To = xWs.Range("B5").Value
.CC = ""
.BCC = ""
.Subject = "November Charges CC"
.Body = "Please return by Monday 12/5 12:00pm CST"
.Attachments.Add xWb.FullName
.Send
End With
.Close SaveChanges:=False
End With
Set xMailObj = Nothing
Kill xTempFilePath & xFileName & xFileExt
End If
Next
Set xOlApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[DanteAmor]

I'm afraid the speed will depend on how fast your own computer is.

Try this:

Sub Mail_Every_Worksheet()
  'Updateby ExtendOffice
  Dim xWs As Worksheet
  Dim xWb As Workbook
  Dim xFileExt As String, xTempFilePath As String, xFileName As String
  Dim xFileFormatNum As Long
  Dim xOlApp As Object, xMailObj As Object
  Dim sBody As String
 
  On Error Resume Next
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With
 
  xTempFilePath = Environ$("temp") & "\"
  If Val(Application.Version) < 12 Then
    xFileExt = ".xls": xFileFormatNum = -4143
  Else
    xFileExt = ".xlsm": xFileFormatNum = 52
  End If
 
  Set xOlApp = CreateObject("Outlook.Application")
  For Each xWs In ThisWorkbook.Worksheets
    If xWs.Range("B5").Value Like "?*@?*.?*" Then
      xWs.Copy
      Set xWb = ActiveWorkbook
      xFileName = xWs.Name & " of " _
        & VBA.Left(ThisWorkbook.Name, VBA.InStr(ThisWorkbook.Name, ".") - 1) & " "
      Set xMailObj = xOlApp.CreateItem(0)
      xWb.Sheets.Item(1).Range("B5").Value = ""
      With xWb
        .SaveAs xTempFilePath & xFileName & xFileExt, FileFormat:=xFileFormatNum
        With xMailObj
          'specify the CC, BCC, Subject, Body below
          .To = xWs.Range("B5").Value
          .CC = ""
          .BCC = ""
          .Subject = "November Charges CC"
          sBody = "Please return by Monday 12/5 12:00pm CST"
          .display
          .HtmlBody = sBody & .HtmlBody
          .Attachments.Add xWb.FullName
          .Send
        End With
        .Close SaveChanges:=False
      End With
      Set xMailObj = Nothing
      Kill xTempFilePath & xFileName & xFileExt
    End If
  Next
 
  Set xOlApp = Nothing
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
End Sub

Note Code Tag:
In future please use code tags when posting code.
How to Post Your VBA Code it makes your code easier to read and copy and it also maintains VBA formatting.
---

 

[lost_in_the_sauce]

What did you change? I'm looking and it seems exactly like what I'm currently using. Sorry, I didn't know to hit the VBA button before posting

Sub Mail_Every_Worksheet()
'Updateby ExtendOffice
  Dim xWs As Worksheet
  Dim xWb As Workbook
  Dim xFileExt As String
  Dim xFileFormatNum As Long
  Dim xTempFilePath As String
  Dim xFileName As String
  Dim xOlApp As Object
  Dim xMailObj As Object
  On Error Resume Next
  With Application
      .ScreenUpdating = False
      .EnableEvents = False
  End With
  xTempFilePath = Environ$("temp") & "\"
  If Val(Application.Version) < 12 Then
    xFileExt = ".xls": xFileFormatNum = -4143
  Else
    xFileExt = ".xlsm": xFileFormatNum = 52
  End If
  Set xOlApp = CreateObject("Outlook.Application")
  For Each xWs In ThisWorkbook.Worksheets
    If xWs.Range("B5").Value Like "?*@?*.?*" Then
      xWs.Copy
      Set xWb = ActiveWorkbook
      xFileName = xWs.Name & " of " _
                   & VBA.Left(ThisWorkbook.Name, VBA.InStr(ThisWorkbook.Name, ".") - 1) & " "
      Set xMailObj = xOlApp.CreateItem(0)
      xWb.Sheets.Item(1).Range("B5").Value = ""
      With xWb
        .SaveAs xTempFilePath & xFileName & xFileExt, FileFormat:=xFileFormatNum
        With xMailObj
        'specify the CC, BCC, Subject, Body below
            .To = xWs.Range("B5").Value
            .CC = ""
            .BCC = ""
            .Subject = "November Amegy CC"
            .Body = "Please return by Monday 12/5 12:00pm CST"
            .Attachments.Add xWb.FullName
            .Send
        End With
        .Close SaveChanges:=False
      End With
      Set xMailObj = Nothing
      Kill xTempFilePath & xFileName & xFileExt
    End If
  Next
  Set xOlApp = Nothing
  With Application
      .ScreenUpdating = True
      .EnableEvents = True
  End With
End Sub

 

[DanteAmor]

Use a test file with 2 or 3 sheets. In cell B5 put a test email, it can even be your own email.

I made these changes:

Sub Mail_Every_Worksheet()
  'Updateby ExtendOffice
  Dim xWs As Worksheet
  Dim xWb As Workbook
  Dim xFileExt As String, xTempFilePath As String, xFileName As String
  Dim xFileFormatNum As Long
  Dim xOlApp As Object, xMailObj As Object
  Dim sBody As String
 
  On Error Resume Next
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With
 
  xTempFilePath = Environ$("temp") & "\"
  If Val(Application.Version) < 12 Then
    xFileExt = ".xls": xFileFormatNum = -4143
  Else
    xFileExt = ".xlsm": xFileFormatNum = 52
  End If
 
  Set xOlApp = CreateObject("Outlook.Application")
  For Each xWs In ThisWorkbook.Worksheets
    If xWs.Range("B5").Value Like "?*@?*.?*" Then
      xWs.Copy
      Set xWb = ActiveWorkbook
      xFileName = xWs.Name & " of " _
        & VBA.Left(ThisWorkbook.Name, VBA.InStr(ThisWorkbook.Name, ".") - 1) & " "
      Set xMailObj = xOlApp.CreateItem(0)
      xWb.Sheets.Item(1).Range("B5").Value = ""
      With xWb
        .SaveAs xTempFilePath & xFileName & xFileExt, FileFormat:=xFileFormatNum
        With xMailObj
          'specify the CC, BCC, Subject, Body below
          .To = xWs.Range("B5").Value
          .CC = ""
          .BCC = ""
          .Subject = "November Charges CC"
          sBody = "Please return by Monday 12/5 12:00pm CST"
          .display
          .HtmlBody = sBody & .HtmlBody
          .Attachments.Add xWb.FullName
          .Send
        End With
        .Close SaveChanges:=False
      End With
      Set xMailObj = Nothing
      Kill xTempFilePath & xFileName & xFileExt
    End If
  Next
 
  Set xOlApp = Nothing
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
End Sub

 

[lost_in_the_sauce]

Thanks, it worked!