We have sent 10000+ looping and writing to the actual pickup directory.
Trap some messages in the pickup directory then notepad to get the layout.
Now just loop your DB and write the eml messages out. Here is one we use,
notice this one drops in a exchange directory so you will need to modify it
for your server. It will send using the built in SMTP server by changing
the directory.
Bryan Martin
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Created 6-9-01 By Bryan Martin
' Script gathers email addresses from the database then sends out a
' mass mailer (txt file) to all recipients. Script allows you to partial
' send based on numbers. Email is formed by placing the email in the
' web server's SMTP server's Pickup folder.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim rnum, StartNum, EndingNum, HTMLFile, PKUPDIR, SENDERADDRESS, SUBJECT,
TODAYDATETIME
Dim tblName
tblName = Inputbox("Enter table name to send emails to:")
StartNum = InputBox("Enter the starting number to start sending emails on.")
EndingNum = InputBox ("Enter the ending number to stop sending emails on.")
HTMLFile = GetFile(InputBox ("Enter the html file to send."))
'HTMLFile = GetFile("M:\Massmailer\Mailer.html")
PKUPDIR = "M:\Program Files\Exchsrvr\Mailroot\vsi 1\PickUp\"
SENDERADDRESS = """Special Promotions"" <
[email protected]>"
SUBJECT = InputBox ("Enter the subject of your message.")
TODAYDATETIME = WeekDayName(WeekDay(Now()), True, vbSunday) & ", " &
Day(Now()) & " " & MonthName(Month(Now())) & " " & Year(Now()) & " " &
Time() & " -0500"
LogFile = "M:\Massmailer\Massmailer_log.txt"
i = 0
Main
Sub Main
SendEmail
Msgbox "Complete, Sent " & rnum & " emails."
End Sub
function SendEmail()
If tblName = "" then Exit Function
set WshShell = WScript.CreateObject("WScript.Shell")
set conn=createobject("adodb.connection")
conn.Open "Driver={SQL Server};" & _
"Server=localhost;" & _
"Database=MailingList;" & _
"Uid=YOURUSERIDHERE" & _
"Pwd=YOURPASSWORDHERE;"
'MySQL = "Select Distinct email From MainMailer Order By email Asc;"
MySQL = "Select Distinct email From " & tblName & " Order By email Asc;"
Set rs = conn.Execute(MySQL)
Do Until rs.EOF OR Clng(rnum) = Clng(StartNum)
rnum = rnum + 1
email = rs("email")
rs.MoveNext
Loop
Dim rcount
rcount = 0
Do Until rs.EOF Or Clng(rnum) = Clng(EndingNum)
rnum = rnum + 1
rcount = rcount + 1
email = rs("email")
'LogFileWrite email
Send_Now(email)
WScript.Sleep 500
rs.MoveNext
Loop
LogFileWrite "Sent " & tblName & ": " & rcount & " emails on " & Now() &
vbcrlf & _
"Sent records " & StartNum & " - " & EndingNum
conn.Close
Set conn = nothing
set WshShell = nothing
End Function
function Send_CDonts_Now(SentTo)
Dim objMail
Set objMail = Server.CreateObject("CDONTS.NewMail")
objMail.To = SentTo
objMail.From = (e-mail address removed)
objMail.Bcc = ""
objMail.Cc = ""
objMail.Subject = SUBJECT
objMail.BodyFormat = 0
objMail.MailFormat = 0
objMail.Body = HTMLFile
objMail.Send
Set objMail = nothing
End Function
function Send_Now(SentTo)
Dim fso
set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.OpenTextFile(PKUPDIR & "TestMessage" & i & ".eml", 2, True)
file.Write "X-Receiver: " & SentTo & vbcrlf _
& "X-Sender: " & SENDERADDRESS & vbcrlf _
& "X-Receiver: " & SentTo & vbcrlf _
& "From: " & SENDERADDRESS & vbcrlf _
& "To: " & SentTo & vbcrlf _
& "Subject: " & SUBJECT & vbcrlf _
& "Date: " & TODAYDATETIME & vbcrlf _
& "MIME-Version: 1.0" & vbcrlf _
& "Content-Type: multipart/alternative;" & vbcrlf _
& " boundary=""----=_NextPart_000_008C_01C0F4D3.5F5A3CC0""" &
vbcrlf _
& "X-MimeOLE: Produced By Microsoft MimeOLE V5.50.4133.2400" & vbcrlf &
vbcrlf _
& "This is a multi-part message in MIME format." & vbcrlf & vbcrlf _
& "------=_NextPart_000_008C_01C0F4D3.5F5A3CC0" & vbcrlf _
& "Content-Type: text/html;" & vbcrlf _
& "charset=""iso-8859-1""" & vbcrlf _
& "Content-Transfer-Encoding: 7bit" & vbcrlf & vbcrlf _
& HTMLFile
i = i + 1
Set fso = nothing
file.close
set file = nothing
End Function
function LogFileWrite(Message)
Dim fso
Set fso = CreateObject("Scripting.FilesystemObject")
Set file = fso.OpenTextFile(LogFile, 8, True)
file.Write Message & vbcrlf
file.close
Set file = nothing
End function
function GetFile(HTMLFile)
Dim fso
Set fso = CreateObject("Scripting.FilesystemObject")
Set file = fso.OpenTextFile(HTMLFile)
GetFile = file.READALL()
file.close
set file = nothing
set fso = nothing
End Function
