Thursday, 13 March 2014

How to Copy and Email the Filtered Data Range as a Attachment to a User with Outlook Email

Excel VBA Macro to Copy and Email the Filtered Data as a Attachment to a User with Outlook Email
Sub MailMyRange_User()
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim TargetFilePath As String
    Dim TargetFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object
    
    Dim SigString As String
    Dim Signature As String
    Dim Strbody As String
    
    TargetFilePath = "C:\Users\TPReddy\Desktop\Tamatam\"
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    Strbody = "<H3><B>TEST MAIL via EXCEL MACRO</B></H3>" & _
              "This is sample test mail by Macro<br>" & _
              "Please donot repond to it<br>" & _
              "<A href=""www.excelkingdom.blogspot.in"">Excel Kingdom</A>" & _
              "<br><br><B>Thank you</B>"
              
    Application.DisplayAlerts = False
    
'Copying the filtered Data range from your Data Sheet'
    ActiveSheet.Range("A1").Select
    Selection.AutoFilter Field:=1, Criteria1:=Array("143","123"), _
    Operator:=xlFilterValues
   
    ActiveSheet.AutoFilter.Range.Copy ' Copy all columns data in Filtered Range
    
    'On Error Resume Next
        'If Val(Application.Version) < 12 Then
        ' You are using Excel 2000 or 2003.
       ' FileExtStr = ".xls": FileFormatNum = -4143
    'Else
        'You are using Excel 2007 or 2010.
        'FileExtStr = ".xlsx": FileFormatNum = 51
    'End If
    
'Saving the filtered Data range Copied from your Data Sheet to New Workbook'
    Workbooks.Add (xlWBATWorksheet)
    ActiveWorkbook.ActiveSheet.Range("A1").PasteSpecial
    
    ActiveWorkbook.SaveAs TargetFilePath & "Test.xlsx"
    ActiveWorkbook.Close
    
    TargetFileName = TargetFilePath & "Test.xlsx"

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

'Change only 'YourSignature.htm' to the name of your signature
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\YourSignature.htm"

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

'On Error Resume Next
        With OutMail
            .To = "youremail@domain.com"
            .CC = " "
            .BCC = ""
            .Subject = "Test File"
            .HTMLBody = Strbody & "<br>" & Signature
            .Attachments.Add (TargetFileName)
'In place of the following statement, you can use ".Display" to display the e-mail message.
            .Send
        End With        
          
    Set OutMail = Nothing
    Set OutApp = Nothing

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

You Should Use this Function in your Module to work Macro to Insert Signature in Your Email
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
-------------------------------------------------------------------------------------------------------------------
Tips or Notes :

In the above macro above we use .HTMLBody to add text and a Signature to the mail but what if you want to use .Body to create a plain message ?

Example : Mail_Outlook_With_Signature_Html

Change the Strbody line to

    Strbody = "Hi there" & vbNewLine & vbNewLine & _
              "This is line 1" & vbNewLine & _
              "This is line 2" & vbNewLine & _
              "This is line 3" & vbNewLine & _
              "This is line 4"
Change the .HTMLBody line to  .Body = Strbody & vbNewLine & Signature

Also change the extension(htm) of the signature file named MySig.htm in the SigString to txt
-------------------------------------------------------------------------------------------------------------------
Thanks,
TAMATAM



No comments:

Post a Comment

Follow Me by Email

ExcelKingdom-Popular Posts

ExcelKingdom-Random Posts