Paste results of filtered sheet into new email - from within Publisher userform

RolandW

New Member
Joined
Mar 10, 2021
Messages
1
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Good day all. Long time reader, first time poster. I have a unique goal which I am not exactly sure is even possible. I have working code that (from an excel userform) opens up another closed workbook, filters for criteria and then pastes the results into a new Outlook email. It uses three parts including "RangetoHTML" to accomplish this. Part of making this work is creating a temp sheet in the workbook with the form, not the one with the data. It copies the filtered data into this temp sheet before pasting it into the body of the new email. I am now building my form in Publisher, the problem is, Publisher does not have sheets so there is no "temp" sheet to facilitate the process.

As I said in the beginning, I'm not even sure if this is possible, I am not an experienced coder and am just getting started (I hope to get good one day!). The short version of the question: Is it possible to remotely open a workbook, filter copy/paste results into a new email from Publisher? Or, a way to avoid "RangetoHTML" all together? Thanks for taking a look at this.

VBA Code:
Private Sub CommandButtonReport_Click()
'----------------------------------------------------------------------
'Pulls report from workbook and pastes it into new email.
'----------------------------------------------------------------------
    Dim My_Range As Range
    Dim DestSh As Worksheet
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim FilterCriteria As String
    Dim CCount As Long
    Dim rng As Range
    Dim MyPassword As String
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim StrBody As String
    Dim StrBody2 As String
    Dim StrBody3 As String
    Dim StrBodyRoles As String
    Dim StrBodyGroups As String
    Dim index As String
    Dim oExcel As Excel.Application
    Dim wb As Excel.Workbook
    Dim ws As Worksheet
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    
index = "S:\path\workbook.xlsx" 'path to workbook

    Set oExcel = New Excel.Application
    Set wb = Excel.Workbooks.Open(index)
    
    Set My_Range = Range("B2:H" & Lastrow(ActiveSheet))
    My_Range.Parent.Select

    Set DestSh = ThisWorkbook.Sheets("Temp")

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

    My_Range.Parent.AutoFilterMode = False

    My_Range.AutoFilter Field:=1, Criteria1:=ComboBox.Value

    CCount = 0
    On Error Resume Next
    CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
    On Error GoTo 0
    If CCount = 0 Then
        MsgBox "There are more than 8192 areas:" _
             & vbNewLine & "It is not possible to copy the visible data." _
               vbOKOnly, "Copy to worksheet"
    Else
       
        With My_Range.Parent.AutoFilter.Range
            On Error Resume Next
           
            Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
                      .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not rng Is Nothing Then
                
                rng.Copy
                
Sheet2.Activate

                With Sheet2.Range("B" & Lastrow(DestSh) + 1)
                    
                    .PasteSpecial Paste:=8
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
                
            End If
        End With
    End If
        
    My_Range.Parent.AutoFilterMode = False

    ActiveWindow.View = ViewMode
    Application.GoTo Sheet2.Range("B2")
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
    
    Workbooks("workbook.xlsx").Close savechanges:=False
    'wb.Close 'closes the workbook
    
StrBody = "Thank you for your request." & "<br><br>" & _
"Please contact us if you have any questions." & "<br><br>" & _
"column1, column2, column3, column4, column5, column6, column7"

    Set rng = Nothing
    Set rng = Sheets("Temp").UsedRange
    On Error Resume Next
    'Only the visible cells in the selection
    
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

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

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

    On Error Resume Next
    With OutMail
        .SentOnBehalfOfName = "myemail"
        .To = TextBoxEmail.Text
        .attachments.Add "S:\path\workbook.docx"
        .Subject = "report"
        .HTMLBody = StrBody & "<br>" & _
        RangetoHTML(rng) & "<br>" & _
        .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Function Lastrow(sh As Worksheet)
'----------------------------------------------------------------------
'Finds value match of column "B" in workbook when "CommandButtonReport" is clicked.
'----------------------------------------------------------------------
    On Error Resume Next
    Lastrow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("B3"), _
                            Lookat:=xlPart, _
                            LookIn:=xlValues, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Function RangetoHTML(rng As Range)
'----------------------------------------------------------------------
'Converts "copy data" to a temp .html document for pasting into email, then deletes itself.
'----------------------------------------------------------------------
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook.
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the temp htm file.
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top