Send Data from Filtered Table via Outlook email-CodePudding

I am trying to create a VBA that will allow me to send Outlook emails to the designated distributors with information about the project and info from a filtered table data. The filter is based on the distributor's name. Below is the code I have written so far.

Sub EmailDistro_1()

Dim xStrFile As String

    Dim xOutApp As outlook.Application
    Dim xMailOut As outlook.MailItem
    Application.ScreenUpdating = False
    Set xOutApp = CreateObject("Outlook.Application")
    Set xMailOut = xOutApp.CreateItem(olMailItem)
    
    ActiveSheet.Range("Distributor").AutoFilter field:=2, Criteria1:=Cells(2, 2).Value
ActiveSheet.ListObjects("Distributor").Range.Copy

        
        With xMailOut
         .Display
            .To = Range("D2").Value
            .Subject = Range("B8").Value & " " & Range("B9").Value & " - " & Range("B11").Value & " Tile RFQ"
            .HTMLBody = "<p style='font-family:calibri;font-size:12.0pt'>" & Split(Range("C2").Value, " ")(0) & "," & "<br/>" & vbCrLf & "Can you please provide me with pricing, lead times AND rough freight to Zipcode 21850 (Forklift on site)." & "<br/>" & vbCrLf & "<br/>" & vbCrLf & .HTMLBody                           
     
         End With
    
    Set xMailOut = Nothing
    Set xOutApp = Nothing
    Application.ScreenUpdating = True

End Sub

Photo 1 is how I want the email to populate

Photo 2 is the excel sheet I am working off of.

CodePudding user response：

I modified using WordEditor But I cannot get the Job Info Range to Paste. Also I lose my email signature at the bottom. How can I paste the JobInfo Range, Paste the Table and also keep my signature.

Sub EmailDistro_1()

Dim xStrFile As String

    'Declare Outlook Variables
    Dim oLookApp As Outlook.Application
    Dim oLookItm As Outlook.MailItem
    Dim oLookIns As Outlook.Inspector

   
    'Declare Word Variables
    Dim oWrdDoc As Word.Document
    Dim oWrdRng As Word.Range
    Dim oWrdTble As Word.Table
    
    
    'Declare Excel Variables
    Dim ExcTbl As ListObject
    
        
    On Error Resume Next
    
    
    'Get The Active instance of Outlook, if there is one.
    Set oLookApp = GetObject(, "Outlook. Application")
    
        'If ther is no active instance create one
        If Err.Number = 429 Then
            
            'Create a new instance
            Set oLookApp = New Outlook.Application
    
                End If
      
        'Create a new Email
        Set oLookItm = oLookApp.CreateItem(olMailItem)
                
        'Create a reference to Job Info
        Set ExlRange = Sheet4.Range("A8:C13")
                
        'Create a refernce to the table
         Set Exltbl = ActiveSheet.ListOjects(1)
      
        
        With oLookItm
      
         'Basic Info
            .To = Range("D2").Value
            .Subject = Range("B8").Value & " " & Range("B9").Value & " - " & Range("B11").Value & " Tile RFQ"
            .HTMLBody = "<p style='font-family:calibri;font-size:12.0pt'>" & Split(Range("C2").Value, " ")(0) & "," & "<br/>" & vbCrLf & "Can you please provide me with pricing, lead times AND rough freight to Zipcode 21850 (Forklift on site)." & .HTMLBody
                 
                 
          'Display Email
             .Display
   
                 
         'Get The Inspector
         Set oLookIns = .GetInspector
         
         'Get the Word Editor
         Set oWrdDoc = oLookIns.WordEditor
                       
        'Copy Job Info
        ActiveSheet.ListObjects("A8:C13").Range.Copy
         
         'Copy the table
        ActiveSheet.Range("Distributor").AutoFilter field:=2, Criteria1:=Cells(2, 2).Value
        ActiveSheet.ListObjects("Distributor").Range.Copy
        
          'Define Range we want to paste Table in
        Set oWrdRng = oWrdDoc.Application.ActiveDocument.Content
            oWrdRng.Collapse Direction:=wdCollapseEnd
        
         'Add a Break
        Set oWrdRng = oWrdDoc.Paragraphs.Add
            oWrdRng.InsertBreak
            
        'Paste The Range
        ActiveSheet.ListObjects("A8:C13").Range.Paste
        
        'Paste The Table
        oWrdRng.PasteSpecial DataType = wdPasteMetafilePicture
        
                 
        End With
           
    Set oLookItm = Nothing
    Set oLookApp = Nothing
    Application.ScreenUpdating = True

End Sub

CodePudding user response：

Be aware to get the signature added to the message body, you need to call the .Display method before dealing with the HTMLBody property in the code.

You can use the Word object model and deal with the message body represented in Word as a Document instance, so you could simply use the Paste method to insert the copied data in Excel. The WordEditor property returns the Microsoft Word Document Object Model of the message being displayed. See Chapter 17: Working with Item Bodies for more information.