<%
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Spd E-Letter v4
' © 2001, 2002 PensaWorks, inc.
' For help with this program, please visit http://www.pensaworks.com
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function subscribeNew (MLName, MLEmail, MLFormat, MLListID, MLSubscriberID)
' adds a subscriber from the passed information, returning a value based upon success or failure
' 1 = Invalid ListID
' 2 = Invalid Email Address
' 3 = Invalid Format
' 4 = Invalid List (not found)
' 5 = Email Already subscribed to that list
' 6 = Successfull, but no SubscriberID found
' 7 = Successfull, SubscriberID returned as MLSubscriberID
' 8 = Blocked domain
if Trim(MLListID) = "" or NOT IsNumeric(MLListID) Then
subscribeNew = 1 : exit function
else
if NOT VerifyEmail(MLEmail) then
subscribeNew = 2 : exit function
else
if LCase(MLFormat) <> "text" and LCase(MLFormat) <> "html" then
subscribeNew = 3 : exit function
else
set lstCheck = mlConn.Execute("SELECT * FROM ML_Lists WHERE ListID = " & MLListID)
if lstCheck.EOF then
set lstCheck = nothing : subscribeNew = 4 : exit function
else
set lstCheck = nothing
set dupCheck = mlConn.Execute("SELECT * FROM ML_Subscribers WHERE Email = '" & Replace(MLEmail, "'", "''") & "' AND ListID = " & MLListID)
if NOT dupCheck.EOF then
set dupCheck = nothing : subscribeNew = 5 : exit function
else
set dupCheck = nothing
domain = split(MLEmail, "@") : MLDomain = domain(UBound(domain))
set blockedDomain = mlConn.Execute("SELECT * FROM ML_Blocked WHERE blkType = 0 and blkText = '" & replace(MLDomain, "'", "''") & "'")
if NOT blockedDomain.EOF then
set blockedDomain = nothing : subscribeNew = 8 : exit function
else
set blockedDomain = nothing
if (LCase(MLFormat) = "text") then MLFormat = "Text"
if (LCase(MLFormat) = "html") then MLFormat = "HTML"
mlConn.Execute("INSERT INTO ML_Subscribers (Name, Email, Format, ListID, SubscribedDate, numClicks, numReads, numBounces, numReplies) VALUES ('" & Replace(MLName, "'", "''") & "','" & Replace(MLEmail, "'", "''") & "','" & UCase(MLFormat) & "'," & MLListID & ",'" & getNumFromDate(Now) & "',0,0,0,0)")
set getNewSubscriber = mlConn.Execute("SELECT * FROM ML_Subscribers WHERE ListID = " & MLListID & " AND Email = '" & MLEmail & "'")
if getNewSubscriber.EOF then
set getNewSubscriber = nothing : subscribeNew = 6 : exit function
else
MLSubscriberID = getNewSubscriber("SubscriberID") : set getNewSubscriber = nothing
subscribeNew = 7 : exit function
end if
end if
end if
end if
end if
end if
end if
end function
'==============================
function removeSubscriber (MLSubscriberID, strDBType)
' removes a subscriber based upon their subscriber ID
' returns 2 if accepted, 1 otherwise
removeSubscriber = 1
if trim(MLSubscriberID) <> "" AND IsNumeric(MLSubscriberID) then
if lcase(strDBType) = "access" Then
mlConn.Execute("DELETE * FROM ML_Subscribers WHERE SubscriberID = " & MLSubscriberID)
else
mlConn.Execute("DELETE FROM ML_Subscribers WHERE SubscriberID = " & MLSubscriberID)
end if
removeSubscriber = 2 : exit function
end if
end function
'==============================
function getSubscriber(MLSubscriberID, MLListID, MLListName, MLName, MLEmail, MLFormat, MLSubscribed, MLClicks, MLReads)
' gets a subscribers information from an ID number
' 1 = Invalid ID Number
' 2 = Subscriber not found
' 3 = Subscriber found
getSubscriber = 1
if trim(MLSubscriberID) <> "" AND IsNumeric(MLSubscriberID) then
set getSub = mlConn.execute("SELECT ML_Subscribers.ListID, ML_Lists.Listname, ML_Subscribers.Email, ML_Subscribers.Name, ML_Subscribers.Format, ML_Subscribers.SubscribedDate, ML_Subscribers.NumClicks, ML_Subscribers.NumReads, ML_Subscribers.SubscriberID FROM ML_Subscribers INNER JOIN ML_Lists ON ML_Subscribers.ListID = ML_Lists.ListID WHERE ML_Subscribers.SubscriberID = " & MLSubscriberID)
if getSub.EOF then
getSub.Close() : set getSub = nothing
getSubscriber = 2 : exit function
else
MLListID = getSub("ListID")
MLListName = getSub("ListName")
MLEmail = getSub("Email")
MLName = getSub("Name")
MLFormat = getSub("Format")
MLSubscribed = getDateFromNum(getSub("SubscribedDate"))
MLClicks = getSub("numClicks")
MLReads = getSub("numReads")
MLSubscriberID = getSub("SubscriberID")
getSub.Close() : set getSub = nothing
getSubscriber = 3 : exit function
end if
end if
end function
'==============================
function getSubscriber2(MLSubscriberID, MLListID, MLListName, MLName, MLEmail, MLFormat, MLSubscribed, MLClicks)
' gets a subscribers information from an email address and ListID
' 1 = Invalid Data
' 2 = Subscriber not found
' 3 = Subscriber found
getSubscriber2 = 1
if trim(MLListID) <> "" AND IsNumeric(MLListID) AND verifyEmail(MLEmail) then
set getSub = mlConn.execute("SELECT ML_Subscribers.ListID, ML_Lists.Listname, ML_Subscribers.Email, ML_Subscribers.Name, ML_Subscribers.Format, ML_Subscribers.SubscribedDate, ML_Subscribers.NumClicks, ML_Subscribers.NumReads, ML_Subscribers.SubscriberID FROM ML_Subscribers INNER JOIN ML_Lists ON ML_Subscribers.ListID = ML_Lists.ListID WHERE ML_Subscribers.ListID = " & MLListID & " AND ML_Subscribers.Email = '" & trim(MLEmail) & "'")
if getSub.EOF then
getSub.Close() : set getSub = nothing
getSubscriber2 = 2 : exit function
else
MLListID = getSub("ListID")
MLListName = getSub("ListName")
MLEmail = getSub("Email")
MLName = getSub("Name")
MLFormat = getSub("Format")
MLSubscribed = getDateFromNum(getSub("SubscribedDate"))
MLClicks = getSub("numClicks")
MLReads = getSub("numReads")
MLSubscriberID = getSub("SubscriberID")
getSub.Close() : set getSub = nothing
getSubscriber2 = 3 : exit function
end if
end if
end function
'==============================
function editSubscriber(MLSubscriberID, MLListID, MLName, MLEmail, MLFormat)
' adds a subscriber from the passed information, returning a value based upon success or failure
' 1 = Invalid List or Subscriber ID
' 2 = Invalid Email Address
' 3 = Invalid Format
' 4 = Invalid List (not found)
' 5 = Subscriber not found
' 6 = Succsessful
if Trim(MLListID) = "" or NOT IsNumeric(MLListID) or trim(MLSubscriberID) = "" or NOT IsNumeric(MLSubscriberID) then
editSubscriber = 1 : exit function
else
if NOT VerifyEmail(MLEmail) then
editSubscriber = 2 : exit function
else
if LCase(MLFormat) <> "text" and LCase(MLFormat) <> "html" then
editSubscriber = 3 : exit function
else
set lstCheck = mlConn.Execute("SELECT * FROM ML_Lists WHERE ListID = " & MLList)
if lstCheck.EOF then
editSubscriber = 4 : exit function
else
set subCheck = mlConn.Execute("SELECT * FROM ML_Subscribers WHERE SubscriberID = " & MLSubscriberID)
if NOT subCheck.EOF then
editSubscriber = 5 : exit function
else
if (LCase(MLFormat) = "text") then MLFormat = "Text"
if (LCase(MLFormat) = "html") then MLFormat = "HTML"
mlConn.Execute("UPDATE ML_Subscribers SET MLName = '" & MLName & "', MLEmail = '" & MLEmail & "', MLFormat = '" & MLFormat & "' WHERE SubscriberID = " & MLSubscriberID)
editSubscriber = 6 : exit function
end if
end if
end if
end if
end if
end function
'=====================================================================
' The functions below are used throughout the Spd E-Letter and any
' changes to them are not allowed sccording to the license and may
' render the Spd E-Letter inoperable.
'=====================================================================
function getDateFromNum(val)
on error resume next
if len(val) = 0 or len(val) = 1 then
getDateFromNum = Now
else
newDate = dateadd("s", val, "1/1/1980")
newDate = CDate(newDate)
getDateFromNum = newDate
end if
end function
function getNumFromDate(val)
if NOT IsDate(val) then
getNumFromDate = 0
else
getNumFromDate = datediff("s", CDate("1/1/1980"), val)
end if
end function
function replaceData(objName, data)
on error resume next
for each tblField in objName.fields
if (trim(tblField) = "") then newData = " " else newData = tblField
data = replace(data, "#" & tblField.name & "#", newData, 1, -1, 1)
next
replaceData = data
end function
function getNewsletterData(Format, SubscriberID, Email, TestMode, URL, bitResponse)
if (instr(1, URL, "?") <> 0) then
strURL = URL & "&SubscriberID=" & SubscriberID & "&Email=" & server.urlencode(Email) & "&Format=" & Format & "&Test=" & Testmode
else
strURL = URL & "?SubscriberID=" & SubscriberID & "&Email=" & server.urlencode(Email) & "&Format=" & Format & "&Test=" & Testmode
end if
msgBody = getHTML(strURL, bitResponse)
if bitResponse then
getNewsletterData = msgBody
else
getNewsletterData = ""
end if
end function
function countOccurances(strData, strSearch)
dim count, curPos, maxPos, incPos
count = 0
curPos = 1
maxPos = len(strData)
incPos = len(strSearch)
if maxPos > 0 and incPos > 0 then
do until curPos = 0 or curPos >= maxPos
curPos = instr(curPos, strData, strSearch, 1)
if curPos > 0 then
count = count + 1
curPos = curPos + incPos
end if
loop
countOccurances = count
else
countOccurances = 0
end if
end function
function delCommand(strSQL, ELetter_String)
mlConn.Execute(strSQL)
end function
function snippetCount(data)
totalSnippets = 0
do while instr(1, data, "[/snip]", 1) > instr(1, data, "[snip]", 1) and instr(1, data, "[snip]", 1) > 0
totalSnippets = totalSnippets + 1
loop
end function
function snippetCheck(data)
badSnippets = 0
do while instr(1, data, "[/snip]", 1) > instr(1, data, "[snip]", 1) and instr(1, data, "[snip]", 1) > 0
snipStart = instr(1, data, "[snip]", 1) + 6
snipEnd = instr(snipStart, data, "[/snip]", 1)
snipCode = mid(data, snipStart, snipEnd - snipStart)
snipDate = " "
set snipRecord = mlConn.Execute("SELECT snipID, snipData FROM ML_Snippets WHERE snipCode = '" & replace(snipCode, "'", "''") & "'")
if snipRecord.EOF then badSnippets = badSnippets + 1
set snipRecord = nothing
data = replace(data, "[snip]" & snipCode & "[/snip]", snipData, 1, -1, 1)
loop
snippetCheck = badSnippets
end function
function parseSnippets(data, displayError)
do while instr(1, data, "[/snip]", 1) > instr(1, data, "[snip]", 1) and instr(1, data, "[snip]", 1) > 0
snipStart = instr(1, data, "[snip]", 1) + 6
snipEnd = instr(snipStart, data, "[/snip]", 1)
snipCode = mid(data, snipStart, snipEnd - snipStart)
set snipRecord = mlConn.Execute("SELECT snipID, snipData FROM ML_Snippets WHERE snipCode = '" & replace(snipCode, "'", "''") & "'")
if snipRecord.EOF then
if (displayError <> 1) then snipData = "" else snipData = "[b][font size=4]ERROR: Snippet Code NOT found. Please review your newsletter data.[/font][/b]"
else
snipData = snipRecord("snipData")
end if
set snipRecord = nothing
data = replace(data, "[snip]" & snipCode & "[/snip]", snipData, 1, -1, 1)
loop
end function
function listsDropDown(defaultValue, allowedLists, noLists)
loopNum = 0
thisDefaultValue = defaultValue
set getLists = mlConn.Execute("SELECT ListID, ListName FROM ML_Lists ORDER BY ListName ASC")
if getLists.EOF then
noLists = true : exit function
else
noLists = false
while (NOT getLists.EOF)
loopNum = loopNum + 1 : funcListID = getLists("ListID") : funcListName = getLists("ListName")
showOutput = formOutput(thisDefaultValue, funcListID, funcListName, quit)
funcListID = "" : funcListName = ""
getLists.MoveNext()
wend
set getLists = nothing
end if
end function
function allowedList(listID, allowedLists)
allowedList = true
end function
function listWhere(allowedLists, tblPrefix)
listWhere = ""
end function
function whichFormat(format)
if (cstr(lcase(left(Format, 1))) = "h" or cstr(left(Format, 1)) = "0") then whichFormat = "HTML" else whichFormat = "Text"
end function
function sendEmail(Mailer, Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
if NOT verifyEmail(FromEmail) then
sendEmail = 1 : exit function
elseif NOT verifyEmail(ToEmail) then
sendEmail = 2 : exit function
elseif ReplyTo <> "" and NOT verifyEmail(ReplyTo) then
sendEmail = 5 : exit function
elseif trim(Message) = "" then
sendEmail = 6 : exit function
elseif trim(subject) = "" then
sendEmail = 7 : exit function
elseif Mailer = "" then
sendEmail = 8 : exit function
end if
if BCCEmail <> "" then
bccList = split(BCCEmail, ",")
for i = 0 to ubound(bccList)
if NOT verifyEmail(trim(bccList(i))) then
sendEmail = 3 : exit function
end if
next
end if
if CCEmail <> "" then
ccList = split(CCEmail, ",")
for i = 0 to ubound(ccList)
if NOT verifyEmail(trim(ccList(i))) then
sendEmail = 3 : exit function
end if
next
end if
if lcase(trim(Left(format, 1))) = "h" then
format = "text/html"
else
format = "text/plain"
end if
MailerProgram = lcase(cstr(mailer))
select case MailerProgram
case "1", "cdonts", "cdomail"
sendIt = CDONTS_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
case "2", "aspmail"
sendIt = ASPMail_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
case "3", "aspqmail"
sendIt = ASPQMail_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
case "4", "jmail"
sendIt = JMail_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
case "5", "sasmtpmail", "sa-smtpmail"
sendIt = SASmtpMail_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
case "6", "aspemail"
sendIt = ASPEMail_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
case else
sendEmail = 8 : exit function
end select
if NOT sendIt then
sendEmail = 9 : exit function
else
sendEmail = 10 : exit function
end if
end function
function getResponse(val)
if val = 1 then
resp = "1 = Invalid From email"
elseif val = 2 then
resp = "2 = Invalid To email"
elseif val = 3 then
resp = "3 = Invalid BCC email"
elseif val = 4 then
resp = "4 = Invalid CC email"
elseif val = 5 then
resp = "5 = Invalid ReplyTo email"
elseif val = 6 then
resp = "6 = No message"
elseif val = 7 then
resp = "7 = No subject"
elseif val = 8 then
resp = "8 = No mailer selected"
elseif val = 9 then
resp = "9 = Error sending email"
elseif val = 10 then
resp = "10 = Email sent successfully!"
else
resp = "No value returned"
end if
getResponse = resp
end function
function CDONTS_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
if LCase(Right(Format, 1)) = "l" then Format = 0 else Format = 1
set Mailer = Server.CreateObject("CDONTS.NewMail")
if NOT isObject(Mailer) Then
CDONTS_Mailer = false
else
Mailer.MailFormat = Format
Mailer.BodyFormat = Format
Mailer.To = ToName & " <" & ToEmail & ">"
Mailer.From = FromName & " <" & FromEmail & ">"
if (ReplyTo <> "") then Mailer.Value("Reply-To") = ReplyTo
if (BCCEmail <> "") then
Mailer.Bcc = trim(bccEmail)
end if
if (CCEmail <> "") then
Mailer.Cc = trim(ccEmail)
end if
Mailer.Subject = Subject
Mailer.Body = Message
Mailer.Send
if (err.Number <> 0) then CDONTS_Mailer = false else CDONTS_Mailer = true
end if
set Mailer = nothing
end function
function ASPMail_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
set Mailer = Server.CreateObject("SMTPsvg.Mailer")
if NOT isObject(Mailer) Then
ASPMail_Mailer = false
else
Mailer.ContentType = Format
Mailer.RemoteHost = MailerPath
Mailer.FromName = FromName
Mailer.FromAddress = FromEmail
Mailer.ReplyTo = ReplyTo
Mailer.AddRecipient ToName, ToEmail
if (ReplyTo <> "") then Mailer.ReplyTo = ReplyTo
if (BCCEmail <> "") then
bccList = split(BCCEmail, ",")
for i = 0 to ubound(bccList)
Mailer.AddBcc trim(bccList(i)), trim(bccList(i))
next
end if
if (CCEmail <> "") then
ccList = split(CCEmail, ",")
for i = 0 to ubound(ccList)
Mailer.AddCc trim(ccList(i)), trim(ccList(i))
next
end if
Mailer.Subject = Subject
Mailer.BodyText = Message
Mailer.SendMail
if (err.Number <> 0) then ASPMail_Mailer = false else ASPMail_Mailer = true
end if
set Mailer = nothing
end function
function ASPQMail_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
set Mailer = Server.CreateObject("SMTPsvg.Mailer")
if NOT isObject(Mailer) Then
ASPMail_Mailer = false
else
Mailer.ContentType = Format
Mailer.RemoteHost = MailerPath
Mailer.FromName = FromName
Mailer.FromAddress = FromEmail
Mailer.ReplyTo = ReplyTo
Mailer.AddRecipient ToName, ToEmail
if (ReplyTo <> "") then Mailer.ReplyTo = ReplyTo
if (BCCEmail <> "") then
bccList = split(BCCEmail, ",")
for i = 0 to ubound(bccList)
Mailer.AddBCC trim(bccList(i)), trim(bccList(i))
next
end if
if (CCEmail <> "") then
ccList = split(CCEmail, ",")
for i = 0 to ubound(ccList)
Mailer.AddCC trim(ccList(i)), trim(ccList(i))
next
end if
Mailer.Subject = Subject
Mailer.BodyText = Message
Mailer.QMessage = true
Mailer.SendMail
if (err.Number <> 0) then ASPQMail_Mailer = false else ASPQMail_Mailer = true
end if
set Mailer = nothing
end function
function SASmtpMail_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
Set Mailer = Server.CreateObject("SoftArtisans.SMTPMail")
if NOT isObject(Mailer) Then
SASmtpMail_Mailer = false
else
Mailer.RemoteHost = MailerPath
Mailer.contenttype = Format
Mailer.AddRecipient ToName, ToEmail
Mailer.FromName = FromName
Mailer.FromAddress = FromEmail
if (ReplyTo <> "") then Mailer.ReplyTo = ReplyTo
if (BCCEmail <> "") then
bccList = split(BCCEmail, ",")
for i = 0 to ubound(bccList)
Mailer.AddBCC trim(bccList(i)), trim(bccList(i))
next
end if
if (CCEmail <> "") then
ccList = split(CCEmail, ",")
for i = 0 to ubound(ccList)
Mailer.AddCC trim(ccList(i)), trim(ccList(i))
next
end if
Mailer.Subject = Subject
Mailer.BodyText = Message
Mailer.SendMail
if (err.Number <> 0) then SASmtpMail_Mailer = false else SASmtpMail_Mailer = true
end if
set Mailer = nothing
end function
function JMail_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
set Mailer = Server.CreateObject("JMail.SMTPMail")
if NOT isObject(Mailer) Then
JMail_Mailer = false
else
Mailer.ServerAddress = MailerPath & ":" & MailerPort
Mailer.ContentType = Format
Mailer.AddRecipient ToEmail
Mailer.Sender = FromEmail
if (ReplyTo <> "") then Mailer.ReplyTo = ReplyTo
if (BCCEmail <> "") then
bccList = split(BCCEmail, ",")
for i = 0 to ubound(bccList)
Mailer.AddRecipientBCC trim(bccList(i))
next
end if
if (CCEmail <> "") then
ccList = split(CCEmail, ",")
for i = 0 to ubound(ccList)
Mailer.AddRecipientCC trim(ccList(i))
next
end if
Mailer.Subject = Subject
Mailer.Body = Message
Mailer.Execute
if (err.Number <> 0) then JMail_Mailer = false else JMail_Mailer = true
end if
set Mailer = nothing
end function
function ASPEmail_Mailer(Message, FromEmail, ToEmail, FromName, ToName, Subject, MailerPath, MailerPort, Format, BCCEmail, CCEmail, ReplyTo)
set Mailer = Server.CreateObject("Persits.MailSender")
if NOT isObject(Mailer) then
ASPEmail_Mailer = false
else
Mailer.Host = MailerPath
Mailer.Port = MailerPort
Mailer.From = FromEmail
Mailer.FromName = FromName
Mailer.AddAddress ToEmail, ToName
if (ReplyTo <> "") then Mailer.AddReplyTo ReplyTo
if (BCCEmail <> "") then
bccList = split(BCCEmail, ",")
for i = 0 to ubound(bccList)
Mailer.AddBCC trim(bccList(i)), trim(bccList(i))
next
end if
if (CCEmail <> "") then
ccList = split(CCEmail, ",")
for i = 0 to ubound(ccList)
Mailer.AddCC trim(ccList(i)), trim(ccList(i))
next
end if
Mailer.Subject = Subject
Mailer.Body = Message
if (LCase(Left(Format, 1)) = "h") then Mailer.IsHTML = true else Mailer.IsHTML = false
Mailer.Send
if (err.Number <> 0) then ASPEmail_Mailer = false else ASPEmail_Mailer = true
end if
set Mailer = nothing
end function
function verifyEmail(email)
if not isNull(email) then
email = trim(email)
else
verifyEmail = false
exit function
end if
validchars = "abcdefghijklmnopqrstuvwxyz_-.@1234567890"
for i = 1 to len(email)
if instr(validchars, lcase(mid(email, i, 1))) = 0 then
verifyEmail = false
exit function
end if
next
pos1 = instrrev(email, ".")
pos2 = instrrev(email, "@")
if pos1 > pos2 + 1 and pos2 > 1 then
verifyEmail = true
else
verifyEmail = false
end if
end function
function verifyFormat(format)
dim firstChar
format = trim(format)
firstChar = ucase(left(format, 1))
select case firstChar
case "T"
VerifyFormat = "Text"
case "H"
VerifyFormat = "HTML"
case else
VerifyFormat = NULL
end select
end function
function generateSC (encode)
code = 1
for idxChar = 1 to len(encode)
code = code * asc(mid(encode, idxChar, 1)) mod 11111
next
generateSC = code mod 10000
end function
function getHTML(strURL, bitResponse)
dim objXMLHTTP, htmlresponse
set objXMLHTTP = Server.CreateObject("Microsoft.XMLHTTP")
objXMLHTTP.Open "GET", strURL, false
objXMLHTTP.Send
getHTML = trim(objXMLHTTP.responseText)
if (getHTML = "") then bitResponse = false else bitResponse = true
set objXMLHTTP = Nothing
end function
function getDate(num)
if (NOT IsNumeric(num)) then
getDate = "Unknown" : exit function
end if
baseDate = CDate("1/1/1980") : getDate = DateAdd("s", num, baseDate)
end function
function formOutput(defaultValue, formValue, formName, quit)
response.write "" & formName & " " & VbCrLf
end function
function writeShortOutput(formValue, formName, defaultValue, quit)
if (cstr(defaultValue) = cstr(formValue)) then
response.write formValue
quit = true
end if
end function
function writeLongOutput(formValue, formName, defaultValue, quit)
if (cstr(defaultValue) = cstr(formValue)) then
response.write formName
quit = true
end if
end function
function doesFileExist(filePath)
set fso = CreateObject("Scripting.FileSystemObject")
if (fso.FileExists(filePath)) then doesFileExist = true else doesFileExist = false
set fso = nothing
end function
function readFileData(filePath, fileResponse)
if NOT doesFileExist(filePath) then
fileResponse = false : exit function
else
set fso = CreateObject("Scripting.FileSystemObject")
set readFileContents = fso.OpenTextFile(filePath, 1)
readFileData = readFileContents.ReadAll
if (err.Number <> 0) then fileResponse = false
fileResponse = true : set readFileContents = nothing : set fso = nothing : exit function
end if
end function
function validFile(fileName, validTypes)
fileName = split(fileName, ".")
lastPart = UBound(filename)
lastPart = fileName(lastPart)
validFile = false
for i = 0 to UBound(validTypes)
if lcase(validTypes(i)) = lcase(lastPart) then
validFile = true
exit function
end if
next
end function
function listFiles(validTypes, returnFile, baseDirectory)
validTypes = split(validTypes, ",")
basePath = server.mappath(baseDirectory)
currentPath = trim(request("currentPath"))
getPath = trim(request("getPath"))
getPathType = left(getPath, 3)
getPathName = mid(getPath, 4, 10000000)
if getPathType = "fo_" then
getFolder = currentPath & "\" & getPathName
elseif getPathType = "fi_" then
getFolder = currentPath
getFile = currentPath & "\" & getPathName
returnFile = getFile
elseif getPathType = "..." then
if currentPath = basePath then
getFolder = basePath
else
removePart = "\" & Mid(currentPath, InstrRev(currentPath, "\") + 1)
getFolder = replace(currentPath, removePart, "")
end if
else
getFolder = basePath
end if
dim objFSO
set objFSO = Server.CreateObject("Scripting.FileSystemObject")
set objFiles = objFSO.GetFolder(getFolder)
set objFolders = objFiles.SubFolders
response.write " Current Path [" & getFolder & "] "
response.write " ... "
for each f1 in objFolders
response.write " [ " & f1.name & " ] "
next
for each objFile in objFiles.Files
if validFile(objFile.name, validTypes) then
response.write " " & objFile.name & " "
end if
next
response.write "
"
end function
function comCheck(com, debugMode)
if (com <> "") then useCom = lcase(cstr(com)) else useCom = ""
select case useCom
case "1", "cdomail" ' CDONTS
comResults = isCom("CDONTS.NewMail", debugMode)
case "2", "aspmail", "aspqail" ' ASPMail
comResults = isCom("SMTPsvg.Mailer", debugMode)
case "3", "sa-smtpmail" ' SA-SMTP Mail
comResults = isCom("SoftArtisans.SMTPMail", debugMode)
case "4", "jmail" ' Jmail
comResults = isCom("JMail.SMTPMail", debugMode)
case "5", "aspemail" ' ASPEmail
comResults = isCom("Persits.MailSender", debugMode)
case "6", "fso" ' FSO
comResults = isCom("Scripting.FileSystemObject", debugMode)
case "7", "xmlhttp" ' XML
comResults = isCom("Microsoft.XMLHTTP", debugMode)
case "8", "hex" ' Hex Valid Email
comResults = isCom("HexValidEmail.Connection", debugMode)
case "9", "asppop3" ' ASPPop3
comResults = isCom("POP3svg.Mailer", debugMode)
case else
comResults = false
end select
if (comResults) then comCheck = true else comCheck = false
end function
function isCom(component, debugMode)
on error resume next
set testCom = Server.CreateObject(component)
if err.Number = 0 then isCom = true else isCom = false
set testCom = nothing : err.clear()
if debugmode = 1 then
on error resume next
else
on error goto 0
end if
end function
%>