循环中仅发送一条包含HTML代码的消息

Question

按照罗恩·布鲁因（Ron de Bruin）的指示here，我创建了一个小的vba脚本，向我的每个学生发送一封电子邮件，其中附有他们的资格证明。每封邮件均包含文本和两行范围，并以HTML格式编写。

使用脚本中创建的.Display对象的Outmail方法，该例程似乎可以完美地工作。问题是，当我将.Display更改为.Send时，仅发送列表中的第一条消息，并且在测试过程中，由于挂起了挂载，我不得不几次从任务管理器中手动关闭Outlook。没有关闭。如果我这样做并再次运行脚本，则会发送消息，并且每个接收者都会收到两次相同的消息。

我在下面包括了MWE。

我有2个问题：

1）是否有人使用类似的程序遇到了这个问题（并能够找到解决方案）？

2）是否可以使用Outlook在邮件中不包含HTML代码（类似于建议的here）？

在此先感谢您的帮助。

编辑： 这是代码示例：

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