Change VBA code to send only active worksheet

[RLPeloquin]

This code works fine for sending the entire workbook but I need it to send only the active sheet that I'm working on. My hyperlink will always be in "A6". I've tried changing the code from Workbook to Worksheet but I'm still not doing it correctly. I'm sure it's something simple and I'm still new to VBA.
Sub Mail_Every_Worksheet() ' I need it to sent only one sheet at a time.
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

TempFilePath = Environ$("temp") & "\"

If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set OutApp = CreateObject("Outlook.Application")

For Each sh In ThisWorkbook.Worksheets
If sh.Range("A6").Value Like "?*@?*.?*" Then

sh.Copy
Set wb = ActiveWorkbook

TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutMail = OutApp.CreateItem(0)

With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

On Error Resume Next
With OutMail
.To = sh.Range("A6").Value
.CC = ""
.BCC = ""
.Subject = "Power Usage"
.Body = "Your Current Power Usage"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0

.Close savechanges:=False
End With

Set OutMail = Nothing

Kill TempFilePath & TempFileName & FileExtStr

End If
Next sh

Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Logit]

.
This should get you going 99% at least :

Option Explicit

Sub Test_Mail_Sheet_Array()
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim TheActiveWindow As Window
    Dim TempWindow As Window

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook

    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sourcewb.Name & " " & ActiveSheet.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = Sheets("Front Sheet").Range("A6").Value 'I want this to refer to cell B6 on the tab called "Front Sheet" the actual email address(es) will be in that cell
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            '.Send   'or use
            .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Quit
    End With
End Sub

 

[RLPeloquin]

I was hoping for it to only send the active worksheet, not the entire workbook. Thanks for your help

 

[Logit]

.

Option Explicit

Sub Email_Sheet()

   Dim oApp As Object
   Dim oMail As Object
   Dim LWorkbook As Workbook
   Dim LFileName As String

   'Turn off screen updating
   Application.ScreenUpdating = False

   'Copy the active worksheet and save to a temporary workbook
   ActiveSheet.Copy
   Set LWorkbook = ActiveWorkbook

   'Create a temporary file in your current directory that uses the name
   ' of the sheet as the filename
   LFileName = LWorkbook.Worksheets(1).Name & Format(Now, "dd-mmm-yy h-mm-ss")
   
   On Error Resume Next
   
   'Delete the file if it already exists
   Kill LFileName
   On Error GoTo 0
   
   'Save temporary file
   LWorkbook.SaveAs Filename:=LFileName

   'Create an Outlook object and new mail message
   Set oApp = CreateObject("Outlook.Application")
   Set oMail = oApp.CreateItem(0)

   'Set mail attributes (uncomment lines to enter attributes)
   ' In this example, only the attachment is being added to the mail message
   
   With oMail
      .To = ActiveSheet.Range("A6").Value
      .Subject = "Power Usage"
      .body = "Power Usage"
      '"Attached is the file"
      .Attachments.Add LWorkbook.FullName
      .Display
   End With

   'Delete the temporary file and close temporary Workbook
   LWorkbook.ChangeFileAccess Mode:=xlReadOnly
   
   Kill LWorkbook.FullName
   
   LWorkbook.Close SaveChanges:=False

   'Turn back on screen updating
   Application.ScreenUpdating = True
   Set oMail = Nothing
   Set oApp = Nothing

End Sub