This may be a stupid question but
is there a way in _vbscript_ to easily verify that you
have a fuctional connection to the Internet?
I manage a listserve for nurses with close to 700
subscribers. The list usually generates over 100 emails daily and a lots
of error messages. I set up a program alias to capture and
process incoming error messages. This script uses a sql server database
to log and keep a running count of error messages for each bounced email
address. Once that address reaches a set threshold (25 in this
case), the script automatically unsubscribes the email address and
creates a record showing when and why it was unsubscribed.
I launched this a few days ago and it seems to be
working beautifully. The thought just crossed my mind however that
should my server lose Internet connectivity for an extended period, this
script may go into a loop that empties out the users.lst file.
That could be bad.
I'm thinking that I should add logic in the script to
verify Internet connectivity. If the verification fails, then
terminate the script rather than kill the address. I'll paste the code
following this message if anyone would like to offer suggestions. If
there are some VB guru's out there I'd love to get some
collaboration.
Thanks,
Gary
Gary
Jorgenson, RN President - Robin Technologies, Inc.
670 Lakeview Plaza
Blvd., Suite J | Worthington, OH 43085
Phone: 614.888.3001 | Fax:
614.888.3002 | Cell: 614.657.8080
[EMAIL PROTECTED] | www.robintek.com
Dim args, mo, x, re, re2, Matches, cErrorCreator,
cListOwner, iErrorCount
iErrorCount = 1
Set args =
WScript.Arguments
Set re = new regexp 'Create the RegExp object to
extract 1st email address from message body
With re
'find an email
address
.Pattern =
"[EMAIL PROTECTED],4}\b"
.IgnoreCase =
True
.Global = True
End With
Set re2 = new regexp 'Create
a RegExp object to filter out safe messages to list admin
With
re2
'search for safe messages
.Pattern =
"subscribe"
.IgnoreCase = True
.Global = True
End
With
'Load the email into a message object using Quiksoft
Easymail object
Set mo =
CreateObject("EasyMail.Message.6")
mo.LicenseKey="xxxxxxxxxxxxxx
(xxxxxxxxxxxxxxxx)/xxxxxxxxxxxxxxxxxxxx"
x = mo.loadmessage( args.Item(0),
0, 1, 0)
If re2.Test( mo.subject ) = False
Then
Set Matches = re.Execute( mo.bodytext
) ' Execute search.
If Matches.count > 0
Then
cErrorCreator = Matches.Item(0)
End
If
'Create an ADO Connection
Dim cn, rs,
sql
Set cn = CreateObject("ADODB.Connection")
cn.Provider =
"sqloledb"
ProvStr =
"Server=xxxxxx;Database=xxxxxxx;UID=xxxxx;pwd=xxxxxx;"
cn.Open
ProvStr
Set rs = CreateObject("ADODB.RecordSet")
sql=
"SELECT * from error_messages where error_creator = '" & cErrorCreator
& "'"
rs.Open sql, cn, 3, 3
If rs.eof = True
Then
rs.AddNew
rs.fields("error_creator").value
= cErrorCreator
Else
iErrorCount =
(rs.fields("error_count").value +
1)
rs.fields("error_count").value =
iErrorCount
rs.fields("updated_date").value =
Now()
End If
rs.fields("message_from").value =
mo.FromAddr
rs.fields("message_to").value =
mo.Recipients.item(1).Address
rs.fields("message_subject").value =
mo.subject
rs.fields("message_body").value =
mo.bodytext
rs.fields("message_date").value =
mo.date
rs.Update
cListOwner =
rs.fields("message_to").value
rs.close
sql = "select * from listserves where
list_owner_email = '" & cListOwner & "'"
rs.Open sql, cn, 3,
3
If rs.eof = False Then
rs.fields("last_error").value
= Now()
If iErrorCount > rs.fields("error_threshold").value
Then
remove_subscriber
cErrorCreator
End If
rs.Update
End
If
rs.Close
Set rs = Nothing
cn.close
Set
cn = Nothing
End If
Set mo = Nothing
Set re = Nothing
Set re2 =
Nothing
Function remove_subscriber( cAddress )
Dim
rs, rs1, sql
Set rs = CreateObject("ADODB.RecordSet")
Set
rs1 = CreateObject("ADODB.RecordSet")
sql= "SELECT * from
error_messages where error_creator = '" & cErrorCreator &
"'"
rs.Open sql, cn, 3, 3
If rs.eof = False
Then
rs1.Open "select top 0 * from
addresses_dropped", cn, 3,
3
rs1.AddNew
rs1.fields("list_owner").value =
rs.fields("message_to").value
rs1.fields("error_subject").value
=
rs.fields("message_subject").value
rs1.fields("error_email").value
=
rs.fields("error_creator").value
rs1.fields("error_count").value
=
rs.fields("error_count").value
rs1.fields("creation_date").value
=
rs.fields("creation_date").value
rs1.fields("updated_date").value
=
rs.fields("updated_date").value
rs1.fields("dropped_date").value
= Now
rs1.Update
rs1.Close
rs1.Open "SELECT * from listserves where
list_owner_email = '" & rs.fields("message_to").value &
"'"
Dim cFilePath, Item
cFilePath =
rs1.fields("list_file_path").value
rs1.close
Dim objFSO, objFTemp, objFTemp2,
objTextStream
Set objFSO =
CreateObject("Scripting.FileSystemObject")
Set objTextStream =
objFSO.OpenTextFile(cFilePath & "users.lst", 1)
Set
objFTemp = objFSO.CreateTextFile( cFilePath & "new_users.lst",
True)
Set objFTemp2 = objFSO.CreateTextFile( cFilePath &
"users.txt", True)
Do While objTextStream.AtEndOfStream =
False
Item =
Trim(Replace(Replace(objTextStream.ReadLine,"<",""),">",""))
If
Not LCase(Item) = cAddress Then
objFTemp.WriteLine(
Item )
objFTemp2.WriteLine( "<" & Item &
"> " & Item )
End
If
Loop
objTextStream.Close
objFtemp.Close
objFtemp2.Close
objFSO.CopyFile
(cFilePath & "users.lst"), (cFilePath & "users.lst_bak"),
True
objFSO.CopyFile (cFilePath & "new_users.lst"),
(cFilePath & "users.lst"), True
objFSO.DeleteFile
(cFilePath & "new_users.lst"), True
Set objTextStream =
Nothing
Set objFTemp = Nothing
Set objFTemp2 =
Nothing
Set objFSO =
Nothing
rs.delete
End If
rs.close
Set rs = Nothing
Set
rs1 = Nothing
End
Function
