How to email the current worksheet

  • Hi everyone;
    I am trying to write a vba code to email the current worksheet and here is what I have. I tested the commandbutton click and it works without error but then I don't receive any email. The second had the same issue. Please can someone help me check this codes out and see where I went wrong? Thanks.




    Private Sub CommandButton1_Click()
    'For Tips see: http://www.rondebruin.nl/win/winmail/div/tips.htm
    'Working in Excel 2000-2016
    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 I As Long


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


    Set Sourcewb = ActiveWorkbook


    'Copy the sheet to a new workbook
    Sheets("Sheet1").Copy
    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


    ' 'Change all cells in the worksheet to values if you want
    ' With Destwb.Sheets(1).UsedRange
    ' .Cells.Copy
    ' .Cells.PasteSpecial xlPasteValues
    ' .Cells(1).Select
    ' End With
    ' Application.CutCopyMode = False


    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & ""
    TempFileName = "Part of " & Sourcewb.Name & " " _
    & Format(Now, "dd-mmm-yy h-mm-ss")


    With Destwb
    .SaveAs TempFilePath & TempFileName & FileExtStr, _
    FileFormat:=FileFormatNum
    On Error Resume Next
    For I = 1 To 3
    .SendMail "", _
    ""
    If Err.Number = 0 Then Exit For
    Next I
    On Error GoTo 0
    .Close SaveChanges:=False
    End With


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


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

  • This is the other code which I tested out.




    Sub email_clicks()
    Dim OutlookApp As Object
    Dim NewMail As Object
    Dim ActShtName As String
    Dim FileFullPath As String

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


    'Copying the Active Sheet data
    ActiveSheet.Cells.Copy
    ActShtName = ActiveSheet.Name

    'Saving the Active sheet data into a new workbook with Active Sheet name_Today date
    Workbooks.Add (xlWBATWorksheet)
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("A1").Select
    ActiveSheet.Name = ActShtName


    Application.DisplayAlerts = False


    ActiveWorkbook.SaveAs Environ("vbaexcelcodes") & ActShtName & "_" & Format(Now, "dd-mmm-yyyy") & ".xlsx"


    'Storing the Saved file(which we used for attachment later) path into a Variable
    FileFullPath = ActiveWorkbook.Path & "" & ActiveWorkbook.Name


    ActiveWorkbook.Close True


    Application.DisplayAlerts = True

    'Setting up the objects of Outlook Application and New Email
    Set OutlookApp = CreateObject("Outlook.Application")
    Set NewMail = OutlookApp.CreateItem(olMailItem)
    'Set NewMail = OutlookApp.CreateItem(0)


    'Inserting Signature in Email Boday ; Change only 'YourSignature.htm' to the name of your Signature
    SigString = Environ("appdata") & "\Microsoft\Signatures\Tamatam.htm"


    If Dir(SigString) <> "" Then
    Signature = GetBoiler(SigString)
    Else
    Signature = ""
    End If


    'Selecting your desired Email Account for Sending From Account
    'If the account is not in your profile, Then you need to use SentOnBehalfOfName


    For I = 1 To OutlookApp.Session.Accounts.Count
    If OutlookApp.Session.Accounts.Item(I) = "[email protected]" Then
    '--MsgBox OutlookApp.Session.Accounts.Item(I) & " : This is account number " & I
    Acn_No = I
    Exit For
    End If
    Next I


    'Defining the Email Body Message
    Strbody = "<H3><B>TEST MAIL via EXCEL MACRO</B></H3>" & _
    "This is Sample Test Email by Macro<br>" & _
    "Please donot repond to It<br>" & _
    "<A href=""https://excelkingdom.blogspot.in/"">Excel Kingdom</A>"

    On Error Resume Next


    'Opening a New Email to Send


    With NewMail
    .TO = "" 'Your Email Id here
    .CC = ""
    .BCC = ""
    .Subject = "Test Message" 'Your Email Subject here
    '.Body = "This Your Email Boday ; '--You can use below one as well
    .HTMLBody = Strbody & "<br>" & "<br>" & "<B>Thank you</B>" & "<br>" & Signature
    .Attachments.Add FileFullPath '-- Full Path of the Attachment where it is saved.
    .SentOnBehalfOfName = OutlookApp.Session.Accounts.Item(Acn_No)
    '--You can use below one as well
    '.SentOnBehalfOfName = "[email protected]"
    '.SendUsingAccount = OutlookApp.Session.Accounts.Item(Acn_No)
    .Display '--Use .Display to show you the Email before sending it.
    .Send
    End With

    On Error GoTo ErrMsg:
    ' Since mail has been sent with the attachment.You can kill the Source file if not required
    Kill FileFullPath

    ' Set nothing to the objects created.
    Set NewMail = Nothing
    Set OutlookApp = Nothing

    ' Now set the application properties back to true.
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With
    MsgBox "Activesheet as Email Attchment Sent Successfully", vbOKOnly, "Job Done"
    Exit Sub


    ErrMsg:
    MsgBox Err.Description


    End Sub


    'The Function to Look and Get the Email Signature; Calls into above Macro
    Function GetBoiler(ByVal SigFile As String) As String
    Dim FSO As Object
    Dim TS As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TS = FSO.GetFile(SigFile).OpenAsTextStream(1, -2)
    GetBoiler = TS.readall
    TS.Close


    End Function