email code

[Rpettis31]

This code used to work but now it sends a blank email without the temp
workbook info in it. I am now left with a temp workbook and before this
object would be deleted.
Sub JExceptions()
'
' JExceptions Macro
' Macro recorded 6/26/2008 by rep
'
' Send Month end list via email
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Sheets("TWO POWERS PO's").Range("aH1000:AM1100,
AS1000:AU1100")
'Set rng =
Sheets("YourSheet").Range("a2:a1500").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
.EnableEvents = False
.ScreenUpdating = False
End With

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

On Error Resume Next
With OutMail

.to = "rep"
'.to = "rep;[email protected];djb1"
'.CC = "spm;rsk;fdn;rwf"
.BCC = ""
.Subject = "Uniek Review Jiayuan PO's that are late"
.HTMLBody = RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing


End Sub
Function RangetoHTML(rng As Range)
' Revised/Modified by Robert Pettis 3-04-08
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
.Range("a1:f1500").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
End Function

Sub ExcepJiay2P()
'
' ExcepJiay2P Macro
' Macro recorded 6/26/2008 by rep
'
' Speed up application
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' get key dates or day
Sheets("Overview").Select

' Identify current and previous day
CurrDay = Cells(1, 1)
PrevDay = CurrDay - 1

' Select day
If CurrDay = 1 Then Sheets("Day 31").Select
If CurrDay = 2 Then Sheets("Day 1").Select
If CurrDay = 3 Then Sheets("Day 2").Select
If CurrDay = 4 Then Sheets("Day 3").Select
If CurrDay = 5 Then Sheets("Day 4").Select
If CurrDay = 6 Then Sheets("Day 5").Select
If CurrDay = 7 Then Sheets("Day 6").Select
If CurrDay = 8 Then Sheets("Day 7").Select
If CurrDay = 9 Then Sheets("Day 8").Select
If CurrDay = 10 Then Sheets("Day 9").Select
If CurrDay = 11 Then Sheets("Day 10").Select
If CurrDay = 12 Then Sheets("Day 11").Select
If CurrDay = 13 Then Sheets("Day 12").Select
If CurrDay = 14 Then Sheets("Day 13").Select
If CurrDay = 15 Then Sheets("Day 14").Select
If CurrDay = 16 Then Sheets("Day 15").Select
If CurrDay = 17 Then Sheets("Day 16").Select
If CurrDay = 18 Then Sheets("Day 17").Select
If CurrDay = 19 Then Sheets("Day 18").Select
If CurrDay = 20 Then Sheets("Day 19").Select
If CurrDay = 21 Then Sheets("Day 20").Select
If CurrDay = 22 Then Sheets("Day 21").Select
If CurrDay = 23 Then Sheets("Day 22").Select
If CurrDay = 24 Then Sheets("Day 23").Select
If CurrDay = 25 Then Sheets("Day 24").Select
If CurrDay = 26 Then Sheets("Day 25").Select
If CurrDay = 27 Then Sheets("Day 26").Select
If CurrDay = 28 Then Sheets("Day 27").Select
If CurrDay = 29 Then Sheets("Day 28").Select
If CurrDay = 30 Then Sheets("Day 29").Select
If CurrDay = 31 Then Sheets("Day 30").Select

For msg = 12 To 1500
If Cells(msg, 15) <> "ok" And Cells(msg, 15) <> "" Then Cells(msg,
16) = "Please review this PO"
Next msg
Range("a1111").Select
Selection.AutoFilter
Selection.AutoFilter Field:=16, Criteria1:="Please review this PO"
Range("A11:G3968,I11:J3968,O113968").Select
Selection.Copy

Sheets("TWO POWERS PO's").Select

Cells(10000, 15).Select
ActiveSheet.Paste

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Sheets("TWO POWERS PO's").Range("O10000:X10500")
'Set rng =
Sheets("YourSheet").Range("a2:a1500").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
.EnableEvents = False
.ScreenUpdating = False
End With

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

On Error Resume Next
With OutMail
.to = "rep"
' .To = "(e-mail address removed)"
'.CC = "rep;spm;rsk;fdn;rwf;djb1"
.BCC = ""
.Subject = "Two Powers Please Review Jiayuan PO issues"
.HTMLBody = RangetoHTML1(rng)
.Send 'or use .Display
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing


End Sub
Function RangetoHTML1(rng As Range)
' Revised/Modified by Robert Pettis 3-04-08
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
.Range("a1:f1500").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)
RangetoHTML1 = ts.ReadAll
ts.Close
RangetoHTML1 = Replace(RangetoHTML1, "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
End Function

 

[Gary Keramidas]

one thing you can try is comment out the on error resume next line to see if
that's masking an error