Thursday, March 13, 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-------------------------------------------#

How to Check and Count the No.of Files and Sub Folders in a Folder

Excel VBA Macro to Check and Count the No.of Files and Sub Folders exist in a Folder
Sub Check_Count_All_SubFolders_Files()  
    Dim FromPath As String       
    Dim FSO As Object
    Dim ObjFile As Object
    Dim SourceFolder As Object
    Dim ObjSubFolder As Object    
    Dim FileExt As String

'Application.DisplayAlerts = False
'On Error Resume Next

    FromPath = "C:\Users\Tamatam\Desktop\Tamatam\"        
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(FromPath)

'< Checking whether the Folder is Empty or Not >
If (SourceFolder.Files.Count = 0) Then
  MsgBox "Source Folder is Empty"
Else
  MsgBox "The Source Folder Contains " & SourceFolder.Files.Count & " " & "Files and " & SourceFolder.Subfolders.Count & " " & "SubFolders"
End If 
Set FSO = Nothing 'It will clean up the Object from the Memory

End Sub

Thanks, TAMATAM

How to List all the Sub Folders and Files Names in the Message Box

Excel VBA Macro to Display all the Sub Folders and Files Names in the Message Box
Sub List_All_SubFolders_Files()  
    Dim FromPath As String       
    Dim FSO As Object
    Dim ObjFile As Object
    Dim SourceFolder As Object
    Dim ObjSubFolder As Object    
    Dim FileExt As String

'Application.DisplayAlerts = False
'On Error Resume Next
    FromPath = "C:\Users\Tamatam\Desktop\MyFolder\"
        
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(FromPath)
              
'<Loop through to list all subfolders in a folder path >              
For Each ObjSubFolder In SourceFolder.SubFolders    
    MsgBox ObjSubFolder.Name    
Next ObjSubFolder

'<Loop through to list all files in a folder path >
For Each ObjFile In SourceFolder.Files    
    MsgBox ObjFile.Name    
Next ObjFile

End Sub

Thanks,TAMATAM

Featured Post from this Blog

How to compare Current Snapshot Data with Previous Snapshot in Power BI

How to Dynamically compare two Snapshots Data in Power BI Scenario: Suppose, we have a sample Sales data, which is stored with Monthly Snaps...

Popular Posts from this Blog