Outlook Msg

[Cs1585]

Hi Guys,

I've been playing with this code for a week trying to get it to work, its a cut and paste from various versions and the internet of course.

The code is supposed to generate an excel output workbook and copy/paste a selection in the input worksheet of the workbook into the outlook msg and send out to the selected people. `

At this moment I assumed patching the different codes would work but I get Error 424 object required x2.

Any suggestions?

Sub emailReports()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
Dim rng As Range
'Copy Paste Values Inot Email
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("Input").Range("a1:k38").SpecialCells(xlCellTypeVisible)
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
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook

With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
.Sheets(Array("Input", "Output")).Copy
End With
'Copy-paste-value the values
Sheets("Input").Unprotect ("@rs")
Sheets("Output").Unprotect ("@rs")

Sheets("Input").Range("A1:v60").Copy
Sheets("Input").Range("A1:v60").PasteSpecial Paste:=xlPasteValues

Sheets("Output").Range("A1:Bz70").Copy
Sheets("Output").Range("A1:Bz70").PasteSpecial Paste:=xlPasteValues

'Delete only the Forms controls

Dim shp As Shape
Dim testStr As String
For Each shp In ActiveSheet.Shapes
If shp.Type = 8 Then
If shp.FormControlType = 2 Then
testStr = ""
On Error Resume Next
testStr = shp.TopLeftCell.Address
On Error GoTo 0
If testStr <> "" Then shp.Delete
Else
shp.Delete
End If
End If
Next shp

TempWindow.Close
Set Destwb = ThisWorkbook
'Determine the Excel version and file extension/format

With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsx": FileFormatNum = 51
'Select Case Sourcewb.FileFormat
'Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
'Case 52:
'If .HasVBProject Then
'FileExtStr = ".xlsm": FileFormatNum = 52
'Else
'FileExtStr = ".xlsx": FileFormatNum = 51
'End If
'Case 56: FileExtStr = ".xls": FileFormatNum = 56
'Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
'End Select
End If
End With
TempFilePath = Environ("USERPROFILE") & "\Desktop"

'TempFileName = "test"
TempFileName = ThisWorkbook.Sheets("Input").Range("o28")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'WARNING : APPLICATION LEVEL CHANGE
Application.DisplayAlerts = False

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
'On Error Resume Next
On Error GoTo Error_Routine

With OutMail
.to = ThisWorkbook.Sheets("Input").Range("h34").Text & "; " & ThisWorkbook.Sheets("Input").Range("h35").Text & "; " & ThisWorkbook.Sheets("Input").Range("h36").Text
.CC = ""
.BCC = ""
.Subject = ThisWorkbook.Sheets("Input").Range("o28").Value
.HTMLBody = ThisWorkbook.Sheets("Input").Range("n34") & vbLf & vbLf
RangetoHTML (rng)
ThisWorkbook.Sheets("Input").Range ("N51") & vbLf & vbLf & ThisWorkbook.Sheets("Input").Range("n52") & vbLf & vbLf

.Attachments.Add Destwb.FullName
.Display
.Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With

Application.DisplayAlerts = True
Error_Routine:
MsgBox "Error " & Err.Number & " " & Err.Description
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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 to past the data in
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
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
"align=left xublishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
'WARNING : APPLICATION LEVEL CHANGE
Application.DisplayAlerts = True
Error_Routine:
MsgBox "Error " & Err.Number & " " & Err.Description
End Function