VBScript SMTP Auto Email

Question

I have a script to auto email a list of address' stored in Excel, but it is only sending to the first address and not looping to the rest, I cannot seem to fix it:

Set objMessage = CreateObject("CDO.Message") 
Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")

For Each f In fso.GetFolder("Y:\Billing_Common\autoemail").Files
  If LCase(fso.GetExtensionName(f)) = "xls" Then
    Set wb = app.Workbooks.Open(f.Path)

set sh = wb.Sheets("Auto Email Script")
row = 2
email = sh.Range("A" & row)
LastRow = sh.UsedRange.Rows.Count

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim f                                   
Set f = fso.OpenTextFile("Y:\Billing_Common\autoemail\Script\Email.txt", ForReading)                                        
BodyText = f.ReadAll

For r = row to LastRow
    If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then 
    objMessage.Subject = "Billing: Meter Read" 
    objMessage.From = "[email protected]"
    row = row + 1
    objMessage.To = email
    objMessage.TextBody = BodyText

objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2


'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "SERVER ADDRESS HERE"

'Server port
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 

objMessage.Configuration.Fields.Update
objMessage.Send

    End if
Next

f.Close
Set f = Nothing
Set fso = Nothing
wb.Close
End If
Next

Any help would be much appreciated guys!

Thanks!

Answer 1

row = 2
email = sh.Range("A" & row)
...
For r = row to LastRow
  ...
  objMessage.To = email
  ...
Next

You set email to the value of the cell "A2" and never change it. If you want to send a mail to multiple recipients, you should make that

objMessage.To = sh.Range("A" & r).Value

or (better) build a recipient list (assuming that your used range starts with headers in the first table row):

ReDim recipients(LastRow - row)
For r = row To LastRow
  recipients(r - row) = sh.Range("A" & r).Value
Next
objMessage.To = Join(recipients, ";")

and send the message just once. The MTA will handle the rest.

---

Side note: as Vishnu Prasad Kallummel pointed out in the comments your code doesn't close the Excel instance it started. Unlike other objects created in VBScript, Office applications won't automatically terminate with the script, so you have to handle it yourself:

...
wb.Close
app.Quit