<%
'The SendPostingEmail procedure takes the boolean value which identifies a subscriber's status (live or test),
' the id of the subscriber to which was sent the last email and the new/modified posting id.
Sub SendPostingEmail(byRef intSubscriberCount, byRef strLogFileEntry, intSendToLiveSubscribers, intLastSubscriberInPreviousRecipientList, intPostingId, strDelGroupId)
'On Error Resume Next
Server.ScriptTimeout = 10000
Session.Timeout = 1000
dim rsSubscribers
dim objFileSystem, objLogFile, objPostingEmail
dim intNumberOfEmailsPerBatch, intServerTimeOutPeriod, intNumberOfPostingsToDisplay
dim strEmailAddress, strFirstName, strLastName, strTextBody, strHTMLbody, strMultiPartEmail, strServerName, strBaseHREF
dim strPlaceHolder
dim BOUNDARY
dim TEXT_HEADER
dim HTML_HEADER
dim MP_FOOTER
'set the number of emails (subscribers) to send in this batch to 50
intNumberOfEmailsPerBatch = 50
'get a specific number of subscribers (either test or live) that are subscribed to the posting type that the submitted posting belongs to,
' and whose id is greater than the last subscriber in recipient list of previous batch email
Call GetPostingSubscribers(rsSubscribers, Abs(CInt(intSendToLiveSubscribers)), intNumberOfEmailsPerBatch, intLastSubscriberInPreviousRecipientList, GetEmailPostingTypeId(CInt(intPostingId)), strDelGroupId)
'if there are subscribers to email then...
If Not rsSubscribers.Eof Then
'set the number of postings to display after main posting
intNumberOfPostingsToDisplay = 5
'initialize the strLogFileEntry variable:
'if this is the first batch of emails sent for this posting email then
If intLastSubscriberInPreviousRecipientList = 0 Then
'set the strLogFileEntry variable with information relating to the current posting email
strLogFileEntry = Date() & " - Posting Email (" & intPostingId & ")" & " "
Else
'if this is not the first batch of emails sent for this posting email then
'set the strLogFileEntry variable with the PostingEmailLogFileEntry session variable
strLogFileEntry = Session("PostingEmailLogFileEntry")
End If
'set temp smtp server
strServerName = Request.ServerVariables("HTTP_HOST")
'concatenate the strServerName variable to the base href into the strBaseHREF variable
strBaseHREF = "http://" & strServerName
'set the strPlaceHolder variable to swap with the body content of the HTML email
strPlaceHolder = "[body]"
'get the HTML wrapper for the email
strHTMLbody = GetHTMLwrapper(strBaseHREF, strPlaceHolder)
'get the body into the wrapper of the HTML email
strHTMLbody = Replace(strHTMLbody, strPlaceHolder, GetHTMLbody(intPostingId, intNumberOfPostingsToDisplay, strBaseHREF))
'loop through all of the subscribers until there are no more subscribers
Do While Not rsSubscribers.Eof
On Error Resume Next
'increment the intSubscriberCount variable
intSubscriberCount = intSubscriberCount + 1
'get the subscriber info into the relevant variables
intLastSubscriberInPreviousRecipientList = rsSubscribers("SUBSCRIBER_ID")
strEmailAddress = rsSubscribers("SUBSCRIBER_EMAIL")
strFirstName = rsSubscribers("SUBSCRIBER_FIRST_NAME")
strLastName = rsSubscribers("SUBSCRIBER_LAST_NAME")
'begin: use of CDONTS object----------------------------
'concatenate the subscriber's info to the current value of the strLogFileEntry variable
strLogFileEntry = strLogFileEntry & strFirstName & " " & strLastName & " (" & strEmailAddress & "), "
Dim strFrom_x, strTo_x, strSubject_x, strBody_x
strFrom_x = "info@vitesse.ca"
strTo_x = strEmailAddress
If Not CBool(Abs(CInt(intSendToLiveSubscribers))) Then
' strSubject_x = "TEST: Vitesse Re-Skilling Canada Inc."
strSubject_x = "TEST: New management program for engineers at Carleton University"
Else
' strSubject_x = "Vitesse Re-Skilling Canada Inc."
strSubject_x = "New management program for engineers at Carleton University"
End If
strBody_x = Replace(strHTMLbody, "[First Name]", strFirstName)
' Set objPostingEmail = server.CreateObject("CDONTS.NewMail")
' objPostingEmail.BodyFormat = 0 'CdoBodyFormatHTML
' objPostingEmail.MailFormat = 0
' objPostingEmail.From = strFrom_x
' objPostingEmail.To = strTo_x
' objPostingEmail.subject = strSubject_x
' objPostingEmail.Body = strBody_x
' objPostingEmail.Send
Dim iConf, Flds
Set objPostingEmail = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2'cdoSendUsingPort
'.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "r0.zabco.net"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.magma.ca"
.Update
End With
With objPostingEmail
Set .Configuration = iConf
.To = strTo_x
.From = strFrom_x
End With
objPostingEmail.Subject = strSubject_x
objPostingEmail.HTMLBody = strBody_x
objPostingEmail.TextBody = strBody_x
objPostingEmail.Send
'if the email has not been successfully sent then...
If err.number <> 0 Then
'Write mail object error message to log file variable
' strLogFileEntry = strLogFileEntry & "Mail failure occured - Reason: " & err.description & vbCRLF & vbCRLF
strLogFileEntry = strLogFileEntry & "Mail failure occured - " & strFirstName & " " & strLastName & "(" & strEmailAddress & ") Reason: " & Err.Description & " (" & Err.Number & ")" & vbCRLF & vbCRLF
End If
On Error Goto 0
Set objPostingEmail = Nothing
'end: use of CDONTS object----------------------------
'move to the next subscriber
rsSubscribers.MoveNext
Loop
'sub loop end
'reset the server timeout period
' Server.ScriptTimeout = intServerTimeOutPeriod
'release the data connection and recordset objects from memory
rsSubscribers.Close
Set rsSubscribers = Nothing
conn.close
set conn = nothing
'set the PostingEmailLogFileEntry session variable with the strLogFileEntry variable
Session("PostingEmailLogFileEntry") = strLogFileEntry
'send another batch of emails
Response.Redirect "/admin/send_email.asp?sub_count=" & intSubscriberCount & "&is_live=" & CInt(intSendToLiveSubscribers) & "&last_sub=" & intLastSubscriberInPreviousRecipientList & "&posting_id=" & intPostingId & "&selectedGroups=" & strDelGroupId
'if there are no subscribers to email then...
Else
'release the data connection and recordset objects from memory
rsSubscribers.Close
Set rsSubscribers = Nothing
conn.close
set conn = nothing
'set the PostingEmailLogFileEntry session variable with the total number of emails sent
strLogFileEntry = Session("PostingEmailLogFileEntry") & "Total number of emails sent: " & intSubscriberCount
End If
On Error GoTo 0
End Sub
'The GetTextBody function takes the multipart email boundary string and the posting id and returns the text to be displayed in a text-only email.
Function GetTextBody(intPostingId, intNumberOfPostingsToDisplay, strBaseHREF)
'On Error Resume Next
dim strTextBody
dim bitEmailIsHTML
dim intPostingTypeId
dim strPostingTypeName
dim strPostingIndexPath
'get the posting type id into the intPostingTypeId variable
intPostingTypeId = GetEmailPostingTypeId(intPostingId)
'get the posting type name into the strPostingTypeName variable
strPostingTypeName = GetEmailPostingTypeName(intPostingTypeId)
'set strTextBody to your message in plain text format
strTextBody = "Hello [First Name]," & vbCRLF & vbCRLF
strTextBody = strTextBody & "As requested, here's the latest addition to the Vitesse Web site: " & strPostingTypeName & ":" & vbCRLF & vbCRLF
'set the strPostingIndexPath variable with the posting index page URL
strPostingIndexPath = GetPostingTypeIndexURL(intPostingTypeId)
'get the main posting's title and abstract into the strHTMLbody variable
strTextBody = strTextBody & GetMainTextPostingEmailAbstract(intPostingId, strBaseHREF, strPostingIndexPath)
'get an index of recent postings of the selected posting type into the strHTMLbody variable
strTextBody = strTextBody & GetTextPostingEmailIndex(intPostingId, intNumberOfPostingsToDisplay, strBaseHREF, strPostingIndexPath, strPostingTypeName)
strTextBody = strTextBody & vbCRLF & vbCRLF & "To unsubscribe from this email, update your email subscription settings:" & vbCRLF & strBaseHREF & "/unsubscribe.asp" & vbCRLF & vbCRLF
'return the text body string
GetTextBody = strTextBody
'if an error has occured report it
If err.number <> 0 Then
Call ReportPostingEmailError("GetTextBody", err.number, err.description)
End If
On Error Goto 0
End Function
Function GetHTMLbody(intPostingId, intNumberOfPostingsToDisplay, strBaseHREF)
dim strHTMLbody
dim bitEmailIsHTML
dim strPostingIndexPath
dim strPostingTypeName
dim intPostingTypeId
'get the posting type id into the intPostingTypeId variable
intPostingTypeId = GetEmailPostingTypeId(intPostingId)
'get the posting type name into the strPostingTypeName variable
strPostingTypeName = GetEmailPostingTypeName(intPostingTypeId)
' "
"
'set the bitEmailIsHTML variable to 1 (true)
bitEmailIsHTML = 1
'set the strPostingIndexPath variable with the posting index page URL
strPostingIndexPath = GetPostingTypeIndexURL(intPostingTypeId)
'get the main posting's title and abstract into the strHTMLbody variable
strHTMLbody = strHTMLbody & GetMainHtmlPostingEmailAbstract(intPostingId, bitEmailIsHTML, strBaseHREF, strPostingIndexPath)
strHTMLbody = strHTMLbody & "
" & vbCRLF & "
" & vbCRLF & _
"
" & vbCRLF & _
"
" & vbCRLF & _
"
"
strHTMLbody = strHTMLbody & "
" & vbCRLF & "
" & vbCRLF
'get an index of recent postings of the selected posting type into the strHTMLbody variable
'strHTMLbody = strHTMLbody & GetHtmlPostingEmailIndex(intPostingId, intNumberOfPostingsToDisplay, strBaseHREF, strPostingIndexPath, strPostingTypeName)
strHTMLbody = strHTMLbody & "
"
GetHTMLbody = strHTMLbody
End Function
'The GetHtmlPostingEmailIndex function takes the posting type id, the number of postings to display and whether the string to return should be text or HTML and returns the an HTML string of the specified amount of postings.
Function GetHtmlPostingEmailIndex(intPostingId, intNumberOfPostingsToDisplay, strBaseHREF, strPostingIndexPath, strPostingTypeName)
'On Error Resume Next
dim cmd
dim strPostingEmailPostings
dim rsPostings
dim strPostingQueryString
dim intPostingTypeId
'get the posting type id into the intPostingTypeId variable
intPostingTypeId = GetEmailPostingTypeId(intPostingId)
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_RECENT_POSTINGS"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamInput, , intPostingTypeId)
cmd.Parameters.Append cmd.CreateParameter("NUMBER_OF_POSTINGS", adInteger, adParamInput, , intNumberOfPostingsToDisplay)
Set rsPostings = cmd.execute
'if there are postings then...
If Not rsPostings.Eof Then
strPostingEmailPostings = "
"
'loop through all of the postings
Do While Not rsPostings.Eof
'if the current posting in the index is different than that of the main posting in the email then...
If intPostingId <> rsPostings("POSTING_ID") Then
strPostingEmailPostings = strPostingEmailPostings & "
"
'(re)set the strPostingQueryString variable to an empty string
strPostingQueryString = ""
'if the current posting (in the recordset) should not open in a new window (is not an external URL/uploaded document) then...
If Not CBool(rsPostings("POSTING_OPENS_IN_NEW_WINDOW")) Then
'get the posting id (as a querystring) into the strPostingQueryString variable
strPostingQueryString = "?id=" & rsPostings("POSTING_ID")
End If
strPostingEmailPostings = strPostingEmailPostings & "
"
End If
'move to the next record in the recordset
rsPostings.MoveNext
Loop
strPostingEmailPostings = strPostingEmailPostings & "
" & vbCRLF
'if there are no postings then...
Else
'alert the user
strPostingEmailPostings = "There are no postings at this time."
End If
'return the posting info
GetHtmlPostingEmailIndex = strPostingEmailPostings
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportPostingEmailError("GetHtmlPostingEmailIndex", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetEmailPostingTypeId function takes a posting id and returs its related posting type id.
Function GetEmailPostingTypeId(intPostingId)
'On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_POSTING_TYPE_ID"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_ID", adInteger, adParamInput, , intPostingId)
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamOutput)
cmd.execute
'return the posting type id
GetEmailPostingTypeId = cmd.Parameters("POSTING_TYPE_ID")
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportPostingEmailError("GetEmailPostingTypeId", err.number, err.description)
End If
On Error Goto 0
End Function
'The PostingEmailDate function assures that the day and month in a date always have 2 digits.
Function PostingEmailDate(originalDate)
dim strDay
dim strMonth
dim strYear
strDay = Day(originalDate)
strMonth = Month(originalDate)
strYear = Year(originalDate)
If Len(strDay) = 1 Then strDay = "0" & strDay
If Len(strMonth) = 1 Then strMonth = "0" & strMonth
PostingEmailDate = strDay & "/" & strMonth & "/" & strYear
End Function
'The ReportError procedure takes an error number and description and outputs them to the screen.
Sub ReportPostingEmailError(strFunctionName, intErrorNumber, strErrorDescription)
Response.Write " The following error has occured in " & strFunctionName & ": " & strErrorDescription & " (#" & intErrorNumber & ")"
Response.End
End Sub
'The GetPostingSubscribers procedure takes the reference of the subscribers recordset, the boolean value identifying a subscriber's status (live or test),
' the number of subscribers to get, the id of the last subscriber in the previous recipient list and the posting type id the subscribers are subscribed to.
Sub GetPostingSubscribers(byRef rsSubscribers, intSendToLiveSubscribers, intNumberOfEmailsPerBatch, intLastSubscriberInPreviousRecipientList, intPostingTypeId, strDelGroupIds)
'On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_POSTING_EMAIL_SUBSCRIBERS"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_IS_LIVE", adInteger, adParamInput, , intSendToLiveSubscribers)
cmd.Parameters.Append cmd.CreateParameter("NUMBER_OF_SUBSCRIBERS", adInteger, adParamInput, , intNumberOfEmailsPerBatch)
cmd.Parameters.Append cmd.CreateParameter("LAST_SUBSCRIBER_FROM_PREVIOUS_LIST", adInteger, adParamInput, , intLastSubscriberInPreviousRecipientList)
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamInput, , intPostingTypeId)
cmd.Parameters.Append cmd.CreateParameter("GROUP_LIST", advarChar, adParamInput,100, strDelGroupIds)
Set rsSubscribers = cmd.execute
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportPostingEmailError("GetPostingSubscribers", err.number, err.description)
End If
On Error Goto 0
End Sub
'The GetPostingIndexURL function takes a posting type id and returs its related index URL (page).
Function GetPostingTypeIndexURL(intPostingTypeId)
'On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_POSTING_INDEX_URL"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamInput, , CInt(intPostingTypeId))
cmd.Parameters.Append cmd.CreateParameter("POSTING_INDEX_URL", adVarchar, adParamOutput, 250)
cmd.execute
'return the posting index URL
GetPostingTypeIndexURL = cmd.Parameters("POSTING_INDEX_URL")
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportPostingEmailError("GetPostingTypeIndexURL", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetMainPosting function takes the posting id and returns all related posting info.
Function GetMainPosting(intPostingId)
'On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_SELECTED_POSTING"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_ID", adInteger, adParamInput, , intPostingId)
'return the posting info
Set GetMainPosting = cmd.execute
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetMainPosting", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetMainHtmlPostingEmailAbstract function takes the posting id, whether the posting is to be displayed as HTML or text, the domain name and the path to the posting index page and returns an abstract of the main posting.
Function GetMainHtmlPostingEmailAbstract(intPostingId, bitEmailIsHTML, strBaseHREF, byVal strPostingIndexPath)
'On Error Resume Next
dim cmd
dim strMainPostingAbstract
dim rsMainPosting
dim strMainPostingBody
dim strMainPostingTitle
dim bolPostingOpensInNewWindow
dim strCarriageReturnDelimiter
'set the strCarriageReturnDelimiter variable with a double pipe (||)
strCarriageReturnDelimiter = "||"
'get the info for the main posting into the rsMainPosting recordset object
Set rsMainPosting = GetMainPosting(intPostingId)
'get the posting title into the strMainPostingTitle variable
strMainPostingTitle = rsMainPosting("POSTING_TITLE_ENG")
'get the boolean value of whether this posting should open in a new window or not
bolPostingOpensInNewWindow = rsMainPosting("POSTING_OPENS_IN_NEW_WINDOW")
'if this posting does not open in a new window then...
If Not bolPostingOpensInNewWindow Then
strPostingIndexPath = strPostingIndexPath & "?id=" & rsMainPosting("POSTING_ID")
strMainPostingBody = rsMainPosting("POSTING_BODY_ENG")
' strMainPostingBody = Replace(rsMainPosting("POSTING_BODY_ENG"), " ", (strCarriageReturnDelimiter & "br" & strCarriageReturnDelimiter))
' strMainPostingBody = Replace(strMainPostingBody, "
")
' strMainPostingBody = Trim(Replace(strMainPostingBody, " ", ""))
'if this posting opens in a new window then...
Else
'get an empty string into the strMainPostingBody variable
strMainPostingBody = ""
End If
'build the HTML table
strMainPostingAbstract = "
" & vbCRLF
'if this posting does not open in a new window then...
If Not bolPostingOpensInNewWindow Then
'concatenate the title and the abstract with a link to read more
strMainPostingAbstract = strMainPostingAbstract & "
"
End If
'close the table
strMainPostingAbstract = strMainPostingAbstract & "
" & vbCRLF
'return the abstract
GetMainHtmlPostingEmailAbstract = strMainPostingAbstract
'release rsMainPosting recordset from memory
rsMainPosting.Close
Set rsMainPosting = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportPostingEmailError("GetMainHtmlPostingEmailAbstract", err.number, err.description)
End If
On Error Goto 0
End Function
'The stripPostingHTML function takes the html code and returns the code stripped of its tags.
Function stripPostingHTML(strHTML)
'On Error Resume Next
Dim objRegExp, strOutput
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<(.|\n)+?>"
'Replace all HTML tag matches with the empty string
strOutput = objRegExp.Replace(strHTML, " ")
'Replace all < and > with < and >
strOutput = Replace(strOutput, "<", "<")
strOutput = Replace(strOutput, ">", ">")
stripPostingHTML = strOutput 'Return the value of strOutput
Set objRegExp = Nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("stripPostingHTML", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetEmailPostingTypeName function takes the posting type id and the user's preferred language and returns the posting type name in the selected language.
Function GetEmailPostingTypeName(intPostingTypeId)
'On Error Resume Next
dim strLanguage
dim cmd
'set the language variable to english
strLanguage = "ENG"
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_POSTING_TYPE_NAME"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamInput, , intPostingTypeId)
cmd.Parameters.Append cmd.CreateParameter("LANGUAGE_ABBREVIATION", adVarchar, adParamInput, 10, strLanguage)
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_NAME", adVarchar, adParamOutput, 50)
cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetPostingTypeName", err.number, err.description)
End If
'return the posting type name
GetEmailPostingTypeName = cmd.Parameters("POSTING_TYPE_NAME")
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'The GetMainTextPostingEmailAbstract function takes the posting id, whether the posting is to be displayed as HTML or text, the domain name and the path to the posting index page and returns an abstract of the main posting.
Function GetMainTextPostingEmailAbstract(intPostingId, strBaseHREF, byVal strPostingIndexPath)
'On Error Resume Next
dim cmd
dim strMainPostingAbstract
dim rsMainPosting
dim strMainPostingBody
dim strMainPostingTitle
dim bolPostingOpensInNewWindow
dim strCarriageReturnDelimiter
'set the strCarriageReturnDelimiter variable with a double pipe (||)
strCarriageReturnDelimiter = "||"
'get the info for the main posting into the rsMainPosting recordset object
Set rsMainPosting = GetMainPosting(intPostingId)
'get the posting title into the strMainPostingTitle variable
strMainPostingTitle = rsMainPosting("POSTING_TITLE_ENG")
'if the title is longer than 65 characters then...
If Len(strMainPostingTitle) > 65 Then
strMainPostingTitle = WordWrap(strMainPostingTitle, 65, vbCRLF, False)
End If
'get the boolean value of whether this posting should open in a new window or not
bolPostingOpensInNewWindow = rsMainPosting("POSTING_OPENS_IN_NEW_WINDOW")
'if this posting does not open in a new window then...
If Not bolPostingOpensInNewWindow Then
'concatenate posting id to the posting index path
strPostingIndexPath = strPostingIndexPath & "?id=" & rsMainPosting("POSTING_ID")
'replace the carriage return tags ( ) with a different string (||br||)
strMainPostingBody = Replace(rsMainPosting("POSTING_BODY_ENG"), " ", (strCarriageReturnDelimiter & "br" & strCarriageReturnDelimiter))
'replace the carriage return tags (
) with a different string (||p||)
strMainPostingBody = Replace(strMainPostingBody, "
", (strCarriageReturnDelimiter & "p" & strCarriageReturnDelimiter))
'get the first 200 characters
strMainPostingBody = Left(strMainPostingBody, 200)
'remove any carriage return tags at the end of the strMainPostingBody string
Select Case True
'if the last characters equal to ' ' then...
Case (Right(strMainPostingBody, 4) = " ")
'remove the last 4 characters
strMainPostingBody = Left(strMainPostingBody, Len(strMainPostingBody) - 4)
'if the last characters equal to '' then...
Case (Right(strMainPostingBody, 3) = "
strMainPostingBody = Replace(strMainPostingBody, vbCRLF, " ")
'replace the ||p|| string with its original
")
'remove any remaining non-breaking-spaces ( ) and leading and trailing whitespace
strMainPostingBody = Trim(Replace(strMainPostingBody, " ", " "))
'if the body is longer than 65 characters then...
If Len(strMainPostingBody) > 65 Then
strMainPostingBody = WordWrap(strMainPostingBody, 65, vbCRLF, False)
End If
'if this posting opens in a new window then...
Else
'get an empty string into the strMainPostingBody variable
strMainPostingBody = ""
End If
'initialize the strMainPostingAbstract variable to an empty string
strMainPostingAbstract = ""
'if this posting does not open in a new window then...
If Not bolPostingOpensInNewWindow Then
'concatenate the title and the abstract with a link to read more
strMainPostingAbstract = strMainPostingAbstract & strMainPostingTitle & vbCRLF & vbCRLF
strMainPostingAbstract = strMainPostingAbstract & strMainPostingBody & vbCRLF
strMainPostingAbstract = strMainPostingAbstract & "Read more... " & strBaseHREF & strPostingIndexPath & vbCRLF & vbCRLF
Else
'concatenate the title as a link
strMainPostingAbstract = strMainPostingAbstract & strMainPostingTitle & vbCRLF
strMainPostingAbstract = strMainPostingAbstract & strBaseHREF & strPostingIndexPath & vbCRLF & vbCRLF
End If
'return the abstract
GetMainTextPostingEmailAbstract = strMainPostingAbstract
'release rsMainPosting recordset from memory
rsMainPosting.Close
Set rsMainPosting = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportPostingEmailError("GetMainTextPostingEmailAbstract", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetTextPostingEmailIndex function takes the posting type id, the number of postings to display and whether the string to return should be text or HTML and returns the an HTML string of the specified amount of postings.
Function GetTextPostingEmailIndex(intPostingId, intNumberOfPostingsToDisplay, strBaseHREF, strPostingIndexPath, strPostingTypeName)
'On Error Resume Next
dim cmd
dim strPostingEmailPostings
dim rsPostings
dim strPostingQueryString
dim intPostingTypeId
'get the posting type id into the intPostingTypeId variable
intPostingTypeId = GetEmailPostingTypeId(intPostingId)
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_RECENT_POSTINGS"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamInput, , intPostingTypeId)
cmd.Parameters.Append cmd.CreateParameter("NUMBER_OF_POSTINGS", adInteger, adParamInput, , intNumberOfPostingsToDisplay)
Set rsPostings = cmd.execute
'if there are postings then...
If Not rsPostings.Eof Then
'initialize the strPostingEmailPostings variable to an empty string
strPostingEmailPostings = ""
strPostingEmailPostings = strPostingEmailPostings & "Other recent Vitesse " & strPostingTypeName & ":" & vbCRLF & vbCRLF
'loop through all of the postings
Do While Not rsPostings.Eof
'if the current posting in the index is different than that of the main posting in the email then...
If intPostingId <> rsPostings("POSTING_ID") Then
strPostingEmailPostings = strPostingEmailPostings & PostingEmailDate(rsPostings("POSTING_DATE")) & Space(5)
'(re)set the strPostingQueryString variable to an empty string
strPostingQueryString = ""
'if the current posting (in the recordset) should not open in a new window (is not an external URL/uploaded document) then...
If Not CBool(rsPostings("POSTING_OPENS_IN_NEW_WINDOW")) Then
'get the posting id (as a querystring) into the strPostingQueryString variable
strPostingQueryString = "?id=" & rsPostings("POSTING_ID")
End If
'if the POSTING_TITLE_ENG recordset value is longer than 65 characters then...
If Len(rsPostings("POSTING_TITLE_ENG")) > 65 Then
strPostingEmailPostings = strPostingEmailPostings & WordWrap(rsPostings("POSTING_TITLE_ENG"), 65, vbCRLF, False) & vbCRLF & Space(15) & strBaseHREF & strPostingIndexPath & strPostingQueryString & vbCRLF & vbCRLF
Else
strPostingEmailPostings = strPostingEmailPostings & rsPostings("POSTING_TITLE_ENG") & vbCRLF & Space(15) & strBaseHREF & strPostingIndexPath & strPostingQueryString & vbCRLF & vbCRLF
End If
End If
'move to the next record in the recordset
rsPostings.MoveNext
Loop
'if there are no postings then...
Else
'alert the user
strPostingEmailPostings = "There are no postings at this time."
End If
'return the posting info
GetTextPostingEmailIndex = strPostingEmailPostings
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportPostingEmailError("GetTextPostingEmailIndex", err.number, err.description)
End If
On Error Goto 0
End Function
'------------------------------------------------------------------------------
' Parameters :
' strWords - Words to add wrapping to
' intWrapLength - Length of each "line"
' str WrapText - Text to wrap words with, such as or vbCrLf
' blnReplaceVbCrLf - True/False, remove vbCrLf from strWords?
'
' Purpose :
' Returns a string embedded with the strWrapText character, depending
' on intWrapLength. Used to insert vbCrLf or in large amounts of
' text for better formatting
'
'------------------------------------------------------------------------------
Function WordWrap(ByVal strWords, ByVal intWrapLength, ByVal strWrapText, ByVal blnReplaceVbCrLf)
Dim arrWords, arrTrailingCharacters, x
Dim intRunningLength
'*** Strip out carriage returns
If blnReplaceVbCrLf Then
strWords = Replace(strWords, vbCrLf, " ")
End If
'*** Split the words into an array using a space. The
'*** second array just makes it easier to add the Wrap Text
arrWords = Split(strWords, " ")
arrTrailingCharacters = Split(strWords, " ")
'*** Set the trailing characters for each word to a space
For x = LBound(arrTrailingCharacters) To UBound(arrTrailingCharacters)
arrTrailingCharacters(x) = " "
Next
'*** Now start looping through the words and adding the wrap text
intRunningLength = 0
For x = LBound(arrWords) To UBound(arrWords)
'*** Calculate the running length of the words
intRunningLength = intRunningLength + Len(arrWords(x) & " ")
'*** If we're at the exact word wrap length, add the wrapping text
'*** at the end of the current word and reset the running length
If intRunningLength = intWrapLength Then
arrTrailingCharacters(x) = strWrapText
intRunningLength = 0
End If
'*** If we've pass the wrapping length, put the wrapping text
'*** at the end of the previous word. Set the running length
'*** to the length of the current word.
If intRunningLength >= intWrapLength And x > 0 Then
arrTrailingCharacters(x - 1) = strWrapText
intRunningLength = Len(arrWords(x) & " ")
End If
Next
'*** Build the words and the wrapping text back together and return them
For x = LBound(arrWords) To UBound(arrWords)
WordWrap = WordWrap & arrWords(x) & arrTrailingCharacters(x)
Next
End Function
Function GetHTMLwrapper(strBaseHREF, strPlaceHolder)
'On Error Resume Next
dim strHTMLwrapper
strHTMLwrapper = "" & vbCRLF & _
"
"
dim intPostingTypeId
dim intNumberOfPostingsToDisplay
'get the posting type id (3 = vital links) into the intPostingType variable
intPostingTypeId = 3
'set the maximum number of postings to 5
intNumberOfPostingsToDisplay = 5
strHTMLwrapper = strHTMLwrapper & GetPostings(intPostingTypeId, intNumberOfPostingsToDisplay, strBaseHREF) & vbCRLF & _
"
" & vbCRLF & _
"
" & vbCRLF & _
"
" & vbCRLF & _
"
" & vbCRLF & _
"
" & vbCRLF & _
"
" & vbCRLF & _
"
" & vbCRLF & _
"" & vbCRLF & _
"
" & vbCRLF & _
"
" & vbCRLF & _
"
" & vbCRLF & _
"
" & vbCRLF & _
"" & vbCRLF & _
"" & vbCRLF & _
"" & vbCRLF & _
"" & vbCRLF & _
""
GetHTMLwrapper = strHTMLwrapper
On Error GoTo 0
End Function
'The GetPostings function takes the posting id and the number of postings to display and returns an index of posting links.
Function GetPostings(intPostingTypeId, intNumberOfPostingsToDisplay, strBaseHREF)
'On Error Resume Next
dim cmd
dim strHomePagePostings
dim rsPostings
dim strPostingPath
dim intPostingCounter
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_RECENT_POSTINGS"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamInput, , intPostingTypeId)
cmd.Parameters.Append cmd.CreateParameter("NUMBER_OF_POSTINGS", adInteger, adParamInput, , intNumberOfPostingsToDisplay)
Set rsPostings = cmd.execute
'if there are postings then...
If Not rsPostings.Eof Then
'initialize the intPostingCounter to 0
intPostingCounter = 0
strHomePagePostings = "" & vbCRLF
Do While Not rsPostings.Eof
'if this is the first iteration in the loop...
If intPostingCounter <> 0 Then
strHomePagePostings = strHomePagePostings & "
"
End If
'increment intPostingCounter
intPostingCounter = intPostingCounter + 1
'concatenate the base href to the link
strHomePagePostings = strHomePagePostings & "" & rsPostings("POSTING_TITLE_ENG") & "" & vbCRLF
'if the link points to a page within the web site then...
'If (InStr(rsPostings("POSTING_BODY_ENG"), "http") > 0) Then
'concatenate the base href to the link
'strHomePagePostings = strHomePagePostings & "" & rsPostings("POSTING_BODY_ENG") & "" & vbCRLF
'if the link does not point to a page within the web site then...
'Else
'concatenate the link
'strHomePagePostings = strHomePagePostings & "" & rsPostings("POSTING_TITLE_ENG") & "" & vbCRLF
'End If
'move to the next record in the recordset
rsPostings.MoveNext
Loop
'concatenate a spacer
strHomePagePostings = strHomePagePostings & "
" & vbCRLF
'if there are no postings then...
Else
'alert the user
strHomePagePostings = "There are no postings at this time."
End If
'return the posting info
GetPostings = strHomePagePostings
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
%>