<% Option Explicit %> <% ' ' Script Name: Tell-A-Friend Script ' Script File: tellafriend.asp ' ' Dim sSiteID, sSiteName, sSiteURL, sSubject sSiteID = Request.Form("SiteID") sSiteName = Request.Form("SiteName") sSiteURL = Request.Form("SiteURL") If sSiteURL = "" Then sSiteURL = Request.ServerVariables("HTTP_REFERER") sSubject = Request.Form("Subject") Dim sName, sFrom, sTo, sComments sName = Request.Form("Name") sFrom = Request.Form("From") sTo = Request.Form("To") sComments = Request.Form("Comments") Dim arrTo arrTo = Split(sTo, ", ") Dim sError sError = "" If FormIsOk() Then StoreEmails() Dim XMLBase Set XMLBase = CreateXMLBaseObject() ResponseToBrowser() SendMailMessages() Else Response.Write "

Error

" & sError & "

Back" End If ' ' ' *********** SUBS & FUNCTIONS *********** ' ' ' ' Function FormIsOk: Checks if there is some error in the posted form ' Function FormIsOk() Dim bHaveValidEmails, i, fs If sSiteID = "" Then sError = "SiteID not configured" Else Set fs = Server.CreateObject("Scripting.FileSystemObject") If Not fs.FolderExists(APPLICATION_FOLDER & "\" & sSiteID) Then sError = "SiteID not configured: Folder doesn't exist" Else If Not fs.FileExists(APPLICATION_FOLDER & "\" & sSiteID & "\page.xsl") Then sError = "SiteID not configured: Page doesn't exist" Else If Not fs.FileExists(APPLICATION_FOLDER & "\" & sSiteID & "\message_html.xsl") Then sError = "SiteID not configured: HTML Message doesn't exist" Else If Not fs.FileExists(APPLICATION_FOLDER & "\" & sSiteID & "\message_text.xsl") Then sError = "SiteID not configured: Text Message doesn't exist" Else If sSiteURL = "" Then sError = "SiteURL not configured" Else If sSiteName = "" Then sError = "SiteName not configured" Else If sSubject = "" Then sError = "Subject not configured" Else If sName = "" Then sError = "You must specify your name" Else If sFrom = "" Then sError = "You must specify your e-mail address" Else If Not IsEmail(sFrom) Then sError = "You must specify a valid e-mail address" Else If sTo = "" Then sError = "You must specify at least one recipient" Else bHaveValidEmails = False For i = 0 to UBound(arrTo) If isEmail(arrTo(i)) Then bHaveValidEmails = True Else arrTo(i) = "" End If Next If Not bHaveValidEmails Then sError = "You must specify at least one valid recipient" End If End If End If End If End If End If End If End If End If End If End If End If Set fs = Nothing End If FormIsOk = (sError = "") End Function ' ' Function IsEmail: Checks if the e-mail address is valid ' Function IsEmail(Byval Email) IsEmail = False If Len(Email) > 5 Then If InStr(Email, "@") > 0 Then If InStr(Email, ".") > 0 Then If Not InStr(Email, " ") > 0 Then IsEmail = True End If End If End If End If End Function ' ' Function StoreEmails: Store all e-mails in the text file ' Function StoreEmails() Dim objFS Set objFS = Server.CreateObject("Scripting.FileSystemObject") Dim objCSV Dim sLine Dim arrData Dim bFromFound, bToFound bFromFound = False Set objCSV = objFS.OpenTextFile(APPLICATION_FOLDER & "\emails.csv", 1, False) Do While Not objCSV.AtEndOfStream sLine = objCSV.ReadLine arrData = Split(sLine, ",") If arrData(2) = sSiteID Then If arrData(0) = sFrom Then bFromFound = True Exit Do End If End If Loop objCSV.Close Set objCSV = Nothing If Not bFromFound Then Set objCSV = objFS.OpenTextFile(APPLICATION_FOLDER & "\emails.csv", 8, True) objCSV.WriteLine sFrom & "," & Replace(sName, ",","") & "," & sSiteID & "," & Now() objCSV.Close Set objCSV = Nothing End If Dim i For i = 0 to UBound(arrTo) If arrTo(i) <> "" Then Set objCSV = objFS.OpenTextFile(APPLICATION_FOLDER & "\emails.csv", 1, False) Do While Not objCSV.AtEndOfStream sLine = objCSV.ReadLine arrData = Split(sLine, ",") If arrData(2) = sSiteID Then If arrData(0) = arrTo(i) Then bFromFound = True Exit Do End If End If Loop objCSV.Close Set objCSV = Nothing If Not bFromFound Then Set objCSV = objFS.OpenTextFile(APPLICATION_FOLDER & "\emails.csv", 8, True) objCSV.WriteLine arrTo(i) & ", ," & sSiteID & "," & Now() objCSV.Close Set objCSV = Nothing End If End If Next Set objFS = Nothing End Function ' ' Function CreateXMLBaseObject: create the base for the XML object ' Function CreateXMLBaseObject() Dim XML, xmlMessage, xmlSiteURL, xmlSiteName, xmlName, xmlFrom, xmlRecipients, xmlComments Dim i Set XML = Server.CreateObject("Msxml2.DOMDocument.3.0") Set xmlMessage = XML.CreateElement("Message") XML.DocumentElement = xmlMessage Set xmlSiteURL = XML.CreateElement("SiteURL") xmlSiteURL.Text = sSiteURL xmlMessage.AppendChild (xmlSiteURL) Set xmlSiteName = XML.CreateElement("SiteName") xmlSiteName.Text = sSiteName xmlMessage.AppendChild (xmlSiteName) Set xmlName = XML.CreateElement("Name") xmlName.Text = sName xmlMessage.AppendChild (xmlName) Set xmlFrom = XML.CreateElement("From") xmlFrom.Text = sFrom xmlMessage.AppendChild (xmlFrom) Set xmlRecipients = XML.CreateElement("Recipients") xmlMessage.AppendChild (xmlRecipients) Set xmlComments = XML.CreateElement("Comments") xmlComments.Text = sComments xmlMessage.AppendChild (xmlComments) Set CreateXMLBaseObject = XML End Function ' ' Function SendMailMessages: Send the message to each e-mail addresses in the arrTo() array ' Function SendMailMessages() Dim xslMessageHTML Set xslMessageHTML = Server.CreateObject("Msxml2.DOMDocument.3.0") xslMessageHTML.Load APPLICATION_FOLDER & "\" & sSiteID & "\message_html.xsl" Dim xslMessageText Set xslMessageText = Server.CreateObject("Msxml2.DOMDocument.3.0") xslMessageText.Load APPLICATION_FOLDER & "\" & sSiteID & "\message_text.xsl" Dim xmlRecipients Set xmlRecipients = XMLBase.DocumentElement.SelectSingleNode("Recipients") Dim xmlTo Set xmlTo = XMLBase.CreateElement("To") xmlRecipients.AppendChild(xmlTo) Dim i Dim objMailer Set objMailer = Server.CreateObject("JMail.Message") With objMailer .FromName = sName .From = sFrom .Subject = sSubject End With For i = 0 to UBound(arrTo) If arrTo(i) <> "" Then xmlTo.Text = arrTo(i) objMailer.ClearRecipients() objMailer.AddRecipient arrTo(i) objMailer.HTMLBody = XMLBase.TransformNode(xslMessageHTML) objMailer.Body = XMLBase.TransformNode(xslMessageText) objMailer.Send (SMTP_SERVER) End If Next End Function Function ResponseToBrowser() Dim xslPage Set xslPage = Server.CreateObject("Msxml2.DOMDocument.3.0") xslPage.Load APPLICATION_FOLDER & "\" & sSiteID & "\page.xsl" Dim xmlRecipients Set xmlRecipients = XMLBase.DocumentElement.SelectSingleNode("Recipients") ' xmlRecipients.RemoveChild(xmlRecipients.childNodes.Item(0)) Dim xmlTo, i For i = 0 to UBound(arrTo) If arrTo(i) <> "" Then Set xmlTo = XMLBase.CreateElement("To") xmlRecipients.AppendChild(xmlTo) xmlTo.Text = arrTo(i) End If Next Response.Write XMLBase.TransformNode(xslPage) End Function %>