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.
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
