Only one message with HTML code in a loop is sent - excel

Question

Following Ron de Bruin's indications here, I created a VBA script to send each of my students an e-mail with their qualification. Each message contains text and a range with two rows and is composed in HTML format.
The routine seems to work using the .Display method of the Outmail object created in the script.
When I change .Display to .Send only the first message in the list is sent and, during tests, several times I had to close Outlook from the Task Manager because it is hung without closing. If I do this and run the script again, then the messages are sent and each receiver receives the message twice.
Here's a sample of the code:
Option Explicit
Sub GetLblAddress()
Dim wb As Workbook
Dim ws As Worksheet
Dim oLblRg As Range
On Error Resume Next
' Range C2:I2 contains labels of points earned in each exercise
Set oLblRg = Application.InputBox(Prompt:="Select labels in worksheet", _
Title:="SEND NOTES", _
Default:="C2:I2", _
Type:=8)
'Missing error trap yet!
Set ws = oLblRg.Parent
Set wb = ws.Parent
SendNotes wb, ws, oLblRg.Address
End Sub
Sub SendNotes(wb As Workbook, ws As Worksheet, sIniAd As String)
Const sSIGN As String = "<br><br>" & "Saludos" & "<br><br>" & "myname here"
Dim wsList As Worksheet
Dim rng As Range
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.mailitem
Dim OutAccount As Outlook.Account
Dim mailAd As String
Dim rw, lstRw, nCol, numSend As Long
Dim sAd, s As String
Dim sTo, sSubj, sBody As String
Dim bSend As Boolean
On Error GoTo CleanUp:
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'worksheet "Listado" contains e-mail addresses in column H
Set wsList = wb.Worksheets("Listado")
With ws
If .Range(sIniAd).Rows.Count <> 1 Or Left(.Range(sIniAd)(1, 1), 1) <> "P" Then
Err.Raise 1
End If
End With
lstRw = ws.Cells(Rows.Count, 1).End(xlUp).Row
'Here begins loop that runs through the range of qualifications
'and send the corresponding row to each student present in the exam
numSend = 0
Application.StatusBar = "Creando instancia de Outlook." 'Just to keep me informed
Set OutApp = CreateObject("Outlook.Application")
Set OutAccount = OutApp.Session.Accounts("MyAddress#gmail.com")
For rw = 3 To lstRw
bSend = False
With ws
nCol = .Range(sIniAd).Columns.Count + 2
sAd = sIniAd & "," & .Cells(rw, 3).Address & ":" & .Cells(rw, nCol).Address
'Range rng contains two rows: labels and marks
Set rng = .Range(sAd)
sTo = wsList.Cells(rw, 8) 'Mail address of the student
sSubj = "Notas del Examen"
sBody = "Hola." & "<br><br>" & "Tu calificación en el examen es:" & "<br><br>"
'Set boolean variable bSend to know wether send a message
bSend = IsNumeric(.Cells(rw, 3)) And UCase(.Cells(rw, 10).Value) = "NO" And sTo <> vbNullString
End With
'Here's the "meat"
If bSend Then
Set OutMail = OutApp.CreateItem(olmailitem)
With OutMail
.To = sTo
.Subject = sSubj
.HTMLBody = sBody & RangetoHTML(rng) & sSIGN
.SendUsingAccount = OutAccount
.Display 'or use .SEND
End With
numSend = numSend + 1
'Sets the "Send" state to Yes
ws.Cells(rw, 10) = "SI"
End If
'Report advance of script into the status bar
Application.StatusBar = "Procesando: " & rw - 2 & "/" & lstRw - 2 & " (" & Format((rw - 2) / (lstRw - 2), "0%") & ")."
Next rw
CleanUp:
Application.StatusBar = False
Application.CutCopyMode = False
Set OutMail = Nothing
Set OutApp = Nothing
Set ws = Nothing
Set wsList = Nothing
If Err.Number <> 0 Then
If Err.Number = 1 Then
MsgBox "Debe seleccionar sólo la fila de ETIQUETAS", vbExclamation, "SEND NOTES"
ElseIf rng Is Nothing Then
MsgBox "No hay un rango seleccionado o la hoja está protegida," & _
vbNewLine & "corregir e intentar nuevamente.", vbExclamation, "SEND NOTES"
Else
MsgBox Err.Description, vbExclamation, "SEND NOTES"
End If
ElseIf numSend = 0 Then
MsgBox "No se han enviado mensajes.", vbInformation, "SEND NOTES"
ElseIf numSend = 1 Then
MsgBox "Se ha enviado 1 mensaje.", vbInformation, "SEND NOTES"
Else
MsgBox "Se han enviado " & numSend & " mensajes.", vbInformation, "SEND NOTES"
End If
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function RangetoHTML(rng As Range)
'Extracted from http://www.rondebruin.nl/win/s1/outlook/bmail2.htm
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).CurrentRegion.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 x:publishsource=", _
"align=left x:publishsource=")
'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
Alternative question: Is it possible to include HTML code in a message without using Outlook (something like what is suggested here)?