Hi,

I need to send a range in the body of an email, and need to repeat this process a number of times. For this I am using a standard range to html procedure which I found on the net, to which I have added a for loop:

Sub Mail_Selection_Range_Outlook_Body()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

'This for loop added by me
For i = 1 to 501
    Set rng = Sheets(1).Range("A" & i & ":D" & i+3).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

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

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

    On Error Resume Next
    With OutMail
        .To = Sheets(2).Range("D" & i). Value
        .Subject = "Details requested"
        .HTMLBody = "Hello, Please find below your details" & chr(13) & chr(13) & RangetoHTML(rng)
        .Send  
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
Next i
End Sub

Function RangetoHTML(rng As Range)
    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"
 
    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
 
    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=") 

    TempWB.Close savechanges:=False 
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
The problem is that, on running the code, only blank emails are created with just the 'To' field populated. The various temp files aren't deleted as well.

The code works perfect when there is no for loop. However when the loop is added, blank emails are created. Can someone help me identify the problem in the code?