<%
'increment script timeout period
Server.ScriptTimeout = 200
'Begin: Declare global variables
dim strDelimiter
dim strLanguage
dim intUserId
dim str2ndLevelTemplatePath
dim strCurrentURL
dim intCurrentURLSectionId
dim strBreadCrumbMenuSystem
dim strSectionList, arSections, arLitSections(6), temp, intCounter
dim Level0
dim Level1
dim level2
dim Level3
dim Level4
dim Level5
Dim bolAltTemplate
'End: Declare global variables
'Begin: Initialize global variables
'set the path into the str2ndLevelTemplatePath for the default (generic) 2nd (and 3rd) level template
str2ndLevelTemplatePath = "/admin/includes/template.asp"
'set the "||" (double pipe) value for the string delimiter
strDelimiter = "||"
'set user's preference of language
strLanguage = Session("Language")
'set user's id
intUserId = Session("UserId")
'get the strCurrentURL value
strCurrentURL = LCase(Trim(Request.ServerVariables("SCRIPT_NAME")))
'get Section Id of current page
intCurrentURLSectionId = GetSectionId(strCurrentURL)
'if there is a url id then...
If GetURLidFromURL(strCurrentURL) <> "" Then
'find out if current url should use the alt template
bolAltTemplate = UsesAltTemplate(GetURLidFromURL(strCurrentURL))
Else
bolAltTemplate = False
End If
strSectionList = trim(strReverse(GetLitValues(intCurrentURLSectionId)))
arSections = split(strSectionList,"/")
intCounter = 0
for each temp in arSections
if temp <> "" then
temp = strReverse(temp)
arLitSections(intCounter) = temp
intCounter = intCounter +1
end if
next
'get the bread crumb trail into the strBreadCrumbMenuSystem variable
strBreadCrumbMenuSystem = GetBreadCrumbMenuSystem(arLitSections)
Level0 = arLitSections(0)
Level1 = arLitSections(1)
level2 = arLitSections(2)
Level3 = arLitSections(3)
Level4 = arLitSections(4)
Level5 = arLitSections(5)
'End:Initialize global variables
'This function gets the section name (Used for Alt tags, headers...)
Function GetSectionName (intSectionId)
dim strSectionName
if (intSectionId <> "") then
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_SECTION_NAME_ENG"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("SECTION_ID", adInteger, adParamInput,,intSectionId)
cmd.Parameters.Append cmd.CreateParameter("SECTION_NAME_ENG", adVarchar, adParamOutput, 250)
cmd.execute
strSectionName = cmd.Parameters("SECTION_NAME_ENG")
set cmd = nothing ' blow away previous cmd object
else
strSectionName = null
end if
GetSectionName = strSectionName
End Function
'This function returns the ParentId of the provided Section
Function GetParent (intSectionId)
dim ParentId
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_PARENT"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("SECTION_ID", adInteger, adParamInput,,intSectionId)
cmd.Parameters.Append cmd.CreateParameter("PARENT_ID", adInteger, adParamOutput)
cmd.execute
ParentId = cmd.Parameters("PARENT_ID")
set cmd = nothing ' blow away previous cmd object
GetParent = ParentId
End Function
'This function returns all the Section Ids that must stay lit
'Get the values of the sections that are supposed to be lit, from the bottom up.
Function GetLitValues (intSectionId)
dim intParentId
dim strLitValues
strLitValues = intSectionId & "/"
do while (intSectionId <> 7) 'until intSection does not relate to Home
intParentId = GetParent(intSectionId) 'Get the Parent Id for a given Section Id
strLitValues = strLitValues & GetParent(intSectionId) & "/" 'Concatenate string of Parent Ids
intSectionId = intParentId 'Current Section Id is now the Parent Id
loop
GetLitValues = strLitValues
End Function
'The GetBreadCrumbMenuSystem function takes an array of (integer) lit section values and returns a breadcrumbtrail navigation system as a string.
Function GetBreadCrumbMenuSystem(arLitSections)
On Error Resume Next
dim strBreadCrumbMenuSystem
dim intCounter
dim strSectionName
'initialize strBreadCrumbMenuSystem to an empty string
strBreadCrumbMenuSystem = ""
'loop through the array of lit sections
For intCounter = LBound(arLitSections) To UBound(arLitSections)
'if the current value in the array is not an empty string
if trim(arLitSections(intCounter)) <> "" then
'if this is not the first iteration in the loop then...
If intCounter <> LBound(arLitSections) Then
'concatenate a character to separate the section names
strBreadCrumbMenuSystem = strBreadCrumbMenuSystem & " > "
End If
'get the section name into the strSectionName variable without the whitespace (replace with non-breaking space)
strSectionName = Replace(GetSectionName(arLitSections(intCounter)), " ", " ")
'if the current section in the array is the current section being visited then...
If (arLitSections(UBound(arLitSections)) = arLitSections(intCounter)) Or (arLitSections(intCounter + 1) = "") Then
strBreadCrumbMenuSystem = strBreadCrumbMenuSystem & strSectionName
Else
strBreadCrumbMenuSystem = strBreadCrumbMenuSystem & "" & strSectionName & ""
End If
end if
next
'return the breadcrumb menu system
GetBreadCrumbMenuSystem = strBreadCrumbMenuSystem
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetBreadCrumbMenuSystem", err.number, err.description)
End If
On Error Goto 0
End Function
'The ReportError procedure takes an error number and description and outputs them to the screen.
Sub ReportError(strFunctionName, intErrorNumber, strErrorDescription)
Response.Write " The following error has occured in " & strFunctionName & ": " & strErrorDescription & " (#" & intErrorNumber & ")"
Response.End
End Sub
'The GetPostingTypeName function takes the posting type id and the user's preferred language and returns the posting type name in the selected language.
Function GetPostingTypeName(intPostingTypeId)
On Error Resume Next
'dim strLanguage - The strLanguage variable is defined in the common_utils.asp file.
dim cmd
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
GetPostingTypeName = cmd.Parameters("POSTING_TYPE_NAME")
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'The IsValidPageNumber function takes the number of subscribers (for a given type - live/test), the number of subscribers displayed per page and
' the current page number and returs the boolean value relating to the validity of the submitted page number (returns true is page number is valid, returns false if is not valid).
Function IsValidPageNumber(intItemCount, intItemsPerPage, intCurrentPage)
'if the total number of subscribers for a given type divided by the number of subscribers that are displayed per page, is greater or equal to the current page number,
' and that the current page number is greater than zero, then return true, otherwise return false.
IsValidPageNumber = CBool(Int(intItemCount/intItemsPerPage) >= (intCurrentPage-1) And intCurrentPage > 0)
End Function
'The GetPageNumberMenu function takes the module name, the current page #, the total number of items and the # of items displayed per page
Function GetPageNumberMenu(strSubscriberType, strCurrentModule, intCurrentPage, intItemCount, intItemsDisplayedPerPage)
On Error Resume Next
dim strPath
dim strPageNumberMenu
dim intTotalPageCount
dim intCounter
'set the strPageNumberMenu variable with default value (empty string)
strPageNumberMenu = ""
'set the path according to the admin module in question
Select Case LCase(strCurrentModule)
'if the current module is the 'subscribers' module then...
Case "subscriber"
'set the strPath variable with the path to the subscribers admin page
strPath = "/admin/subscribers.asp?type=" & strSubscriberType & "&"
'if the current module is the 'url' module then...
Case "url"
'set the strPath variable with the path to the subscribers admin page
strPath = "/admin/urls.asp?"
End Select
'concatenate the page querystring value to the path
strPath = strPath & "page="
'if the total amount of items can all be displayed on the same page then...
If intItemCount < intItemsDisplayedPerPage Then
'set the intTotalPageCount variable to 1
intTotalPageCount = 1
'if the total amount of items cannot all be displayed on the same page then...
Else
'get the number of pages required for the menu system
intTotalPageCount = Int(intItemCount/intItemsDisplayedPerPage)
'add 1 to the intTotalPageCount variable if the number of items overflows
If (intItemCount Mod intItemsDisplayedPerPage) Then
intTotalPageCount = intTotalPageCount + 1
End If
End If
'if the selected page is the first page then...
If intCurrentPage = 1 Then
'start the menu with the 'previous page' menu item (not a link)
strPageNumberMenu = strPageNumberMenu & "< Previous " & vbCRLF
Else
'start the menu with the 'previous page' menu item (link)
strPageNumberMenu = strPageNumberMenu & "< Previous " & vbCRLF
End If
'loop through the page numbers and add them to the menu system
For intCounter = 1 To intTotalPageCount
'if the current page (in the loop) is the selected page then...
If intCounter = intCurrentPage Then
'concatenate the page number between square brackets (without a link)
strPageNumberMenu = strPageNumberMenu & "[" & intCounter & "]"
'if the current page (in the loop) is the selected page then...
Else
'concatenate the page number without a link to the current page (in the loop)
strPageNumberMenu = strPageNumberMenu & "" & intCounter & ""
End If
'concatenate a space between menu items
strPageNumberMenu = strPageNumberMenu & " " & vbCRLF
Next
'if the selected page is the first page then...
If intCurrentPage = intTotalPageCount Then
'end the menu with the 'next page' menu item (not a link)
strPageNumberMenu = strPageNumberMenu & "Next >"
Else
'end the menu with the 'next page' menu item (link)
strPageNumberMenu = strPageNumberMenu & "Next >"
End If
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetPageNumberMenu", err.number, err.description)
End If
'return the page menu
GetPageNumberMenu = strPageNumberMenu
On Error Goto 0
End Function
'The GetSelectedPostingType function takes the posting type id and returns the related posting type information as a recordset.
Function GetSelectedPostingType(intPostingTypeId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_SELECTED_POSTING_TYPE"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamInput, , intPostingTypeId)
'return the posting type recordset
Set GetSelectedPostingType = cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetSelectedPostingType", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'The GetUrlBody function takes the url string and returns its corresponding body string.
Function GetUrlBody(strCurrentURL)
On Error Resume Next
dim cmd
Set cmd = Server.CreateObject("ADODB.Command")
Set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_URL_BODY"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("URL", adVarChar, adParamInput, 250, strCurrentURL)
cmd.Parameters.Append cmd.CreateParameter("BODY", adLongVarChar, adParamOutput, 1000)
cmd.execute
'return the url body
GetUrlBody = cmd.Parameters("BODY")
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetUrlBody", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'The GetUrlBodyAlt function takes the url string and returns its corresponding body string.
Function GetUrlBodyAlt(strCurrentURL)
On Error Resume Next
dim rsURL
dim strSQLurlBody
dim rsSubscriber
dim bolSubscriberExists
strSQLurlBody = "SELECT URL_BODY_ENG FROM URL WHERE URL_ENG = '" & strCurrentURL & "'"
set rsURL = conn.execute(strSQLurlBody)
'return the url body
GetUrlBodyAlt = rsURL("URL_BODY_ENG")
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetUrlBodyAlt", err.number, err.description)
End If
'release rsURL from memory
rsURL.Close
set rsURL = nothing
On Error Goto 0
End Function
'The ContentIsDynamic function takes the current url string and returns whether the page's content is dynamic or not as a boolean value.
Function ContentIsDynamic(strCurrentURL)
On Error Resume Next
dim cmd
Set cmd = Server.CreateObject("ADODB.Command")
Set cmd.ActiveConnection = conn
cmd.CommandText = "SP_CONTENT_IS_DYNAMIC"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("URL", adVarChar, adParamInput, 250, strCurrentURL)
cmd.Parameters.Append cmd.CreateParameter("IS_DYNAMIC", adInteger, adParamOutput, 1)
cmd.execute
'return true if the content for the current url is dynamic, if not return false
ContentIsDynamic = CBool(cmd.Parameters("IS_DYNAMIC"))
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("ContentIsDynamic", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'The GetUrls function returns the all URLs (as a recordset).
Function GetUrls()
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_URLS"
cmd.CommandType = adCmdStoredProc
Set GetUrls = cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetUrls", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'This function returns the Section Id for the Current Page
Function GetSectionId (strCurrentURL)
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_SECTION_ID"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("URL", adVarChar, adParamInput, 250, strCurrentURL)
cmd.Parameters.Append cmd.CreateParameter("SECTION_ID", adInteger, adParamOutput)
cmd.execute
GetSectionId = cmd.Parameters("SECTION_ID")
set cmd = nothing ' blow away previous cmd object
End Function
'The ModifySection_URL procedure takes the url id and the section id and sets the related section record.
Sub ModifySection_URL(intUrlId, intSectionId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_SET_SECTION_URL"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("URL_ID", adInteger, adParamInput, , intUrlId)
cmd.Parameters.Append cmd.CreateParameter("SECTION_ID", adInteger, adParamInput, , intSectionId)
cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("ModifySection_URL", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Sub
'The GetSubsections function takes the parent section id and returns the child sections as a recordset.
Function GetSubsections(intParentId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_CHILD_SECTIONS"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("PARENT_ID", adInteger, adParamInput, , intParentId)
Set GetSubsections = cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetSubsections", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'The SectionIsChildofParent function takes the child id and parent id and returns true if the current parent is related to the current child, otherwise it returns false.
Function SectionIsChildofParent(intChildId, intParentId)
On Error Resume Next
dim rsIsChild
dim strIsChild
'set query
strIsChild = "SELECT * FROM [SECTION] WHERE SECTION_ID = " & intChildId & " AND PARENT_ID = " & intParentId
'set the recordset
Set rsIsChild = conn.execute(strIsChild)
SectionIsChildofParent = Not(rsIsChild.Eof)
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("SectionIsChildofParent", err.number, err.description)
End If
'release recordset from memory
rsIsChild.Close
Set rsIsChild = Nothing
On Error Goto 0
End Function
'The SubsectionIsCurrentURL function takes a section id and a URL and returns true if one of the subsections (of section id) contains a link equal to the URL.
Function SubsectionIsCurrentURL(intParentId, strURL)
dim cmd
dim rsSections
dim bolSubsectionIsCurrentURL
'set default value of bolSubsectionIsCurrentURL to false
bolSubsectionIsCurrentURL = False
'get subsections of (parameter) parent section into the rsSections recordset
Set rsSections = GetSubsections(intParentId)
'if there are subsections then...
If Not rsSections.Eof Then
'loop through the rsSections recordset
Do While Not rsSections.Eof
'if the strURL parameter is equal to the URL_ENG field of the current record in the recordset then...
If rsSections("URL_ENG") = strURL Then
'set the value of bolSubsectionIsCurrentURL to true
bolSubsectionIsCurrentURL = True
'exit the loop
Exit Do
'if the strURL parameter is not equal to the URL_ENG field of the current record in the recordset then...
Else
'check to see if this section's children are associated with current url
bolSubsectionIsCurrentURL = SubsectionIsCurrentURL(rsSections("SECTION_ID"), strURL)
'if the current sub section is the parent of the current url then...
If bolSubsectionIsCurrentURL Then
'exit the loop
Exit Do
End If
End If
'go to the next record in the recordset
rsSections.MoveNext
Loop
End If
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("SubsectionIsCurrentURL", err.number, err.description)
End If
'return the boolean value
SubsectionIsCurrentURL = bolSubsectionIsCurrentURL
'release the recordset from memory
rsSections.Close
Set rsSections = Nothing
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
Function ManageLeftNav(level1, level2, level3, level4)
dim strLeftNav
dim rsLevel2, rsLevel3, rsLevel4, rsLevel5
dim intLevel2ItemId, intLevel3ItemId, intLevel4ItemId, intLevel5ItemId
dim strLevel2ItemName, strLevel3ItemName, strLevel4ItemName, strLevel5ItemName
dim strLevel2ItemURL, strLevel3ItemURL, strLevel4ItemURL, strLevel5ItemURL
dim strLevel2ItemClass, strLevel3ItemClass, strLevel4ItemClass, strLevel5ItemClass
dim bolSubsectionIsCurrentURL
dim intLevel2MenuItemCounter
dim intLevel3MenuItemCounter
dim intLevel4MenuItemCounter
dim intLevel5MenuItemCounter
dim intSpacerHeight
dim intSelected2ndLevelId
dim intSelected3rdLevelId
dim intSelected4thLevelId
'initialize the Level Menu Item Counter vars to 0
intLevel2MenuItemCounter = 0
intLevel3MenuItemCounter = 0
intLevel4MenuItemCounter = 0
intLevel5MenuItemCounter = 0
'get the 2nd level sections according to the value of the selected 2nd level section (level 1)
Set rsLevel2 = GetSubsections(level1)
'if there are 2nd level sections then...
If Not rsLevel2.Eof Then
'begin left nav table structure
strLeftNav = "" & vbCRLF
strLeftNav = strLeftNav & "
" & vbCRLF
'loop through the 2nd level sections (recordset)
Do While Not rsLevel2.Eof
'increment the intLevel2MenuItemCounter variable
intLevel2MenuItemCounter = intLevel2MenuItemCounter + 1
'set the recordset values into the relevant variables
intLevel2ItemId = rsLevel2("SECTION_ID")
strLevel2ItemName = rsLevel2("SECTION_NAME_ENG")
strLevel2ItemURL = rsLevel2("URL_ENG")
strLevel2ItemClass = "firstlevel"
bolSubsectionIsCurrentURL = SubsectionIsCurrentURL(intLevel2ItemId, strCurrentURL)
'if the current url is equal to the url value of the current record in the rsLevel2 recordset or in one of its subsections then...
If (strCurrentURL = strLevel2ItemURL) Or bolSubsectionIsCurrentURL Then
'identify the link class as lit
strLevel2ItemClass = strLevel2ItemClass & "lit"
End If
'concatenate the table structure and the menu items to the left nav string
strLeftNav = strLeftNav & "
" & vbCRLF
'if the current url is equal to the url value of the current record in the rsLevel2 recordset or in one of its subsections then...
If (strCurrentURL = strLevel2ItemURL) Or bolSubsectionIsCurrentURL Then
'get the 3rd level sections according to the value of the intLevel2ItemId variable
Set rsLevel3 = GetSubsections(intLevel2ItemId)
'if there are 3rd level sections then...
If Not rsLevel3.Eof Then
'loop through the 3rd level sections (recordset)
Do While Not rsLevel3.Eof
'increment the intLevel3MenuItemCounter variable
intLevel3MenuItemCounter = intLevel3MenuItemCounter + 1
'set the recordset values into the relevant variables
intLevel3ItemId = rsLevel3("SECTION_ID")
strLevel3ItemName = rsLevel3("SECTION_NAME_ENG")
strLevel3ItemURL = rsLevel3("URL_ENG")
strLevel3ItemClass = "secondlevel"
bolSubsectionIsCurrentURL = SubsectionIsCurrentURL(intLevel3ItemId, strCurrentURL)
'if the current url is equal to the url value of the current record in the rsLevel3 recordset or in one of its subsections then...
If (strCurrentURL = strLevel3ItemURL) Or bolSubsectionIsCurrentURL Then
'set the intSelected2ndLevelId with the value of the intLevel3ItemId variable
intSelected2ndLevelId = intLevel3ItemId
'identify the link class as lit
strLevel3ItemClass = strLevel3ItemClass & "lit"
End If
'concatenate the table structure and the menu items to the left nav string
strLeftNav = strLeftNav & "
" & vbCRLF
'if the current url is equal to the url value of the current record in the rsLevel3 recordset or in one of its subsections then...
If (strCurrentURL = strLevel3ItemURL) Or bolSubsectionIsCurrentURL Then
'get the 4th level sections according to the value of the intLevel3ItemId variable
Set rsLevel4 = GetSubsections(intLevel3ItemId)
'if there are 4th level sections then...
If Not rsLevel4.Eof Then
'loop through the 4th level sections (recordset)
Do While Not rsLevel4.Eof
'increment the intLevel4MenuItemCounter variable
intLevel4MenuItemCounter = intLevel4MenuItemCounter + 1
'set the recordset values into the relevant variables
intLevel4ItemId = rsLevel4("SECTION_ID")
strLevel4ItemName = rsLevel4("SECTION_NAME_ENG")
strLevel4ItemURL = rsLevel4("URL_ENG")
strLevel4ItemClass = "thirdlevel"
bolSubsectionIsCurrentURL = SubsectionIsCurrentURL(intLevel4ItemId, strCurrentURL)
'if the current url is equal to the url value of the current record in the rsLevel4 recordset then...
If strCurrentURL = strLevel4ItemURL Then
'set the intSelected3rdLevelId variable with the value of the current section id
intSelected3rdLevelId = intLevel4ItemId
'identify the link class as lit
strLevel4ItemClass = strLevel4ItemClass & "lit"
End If
'concatenate the table structure and the menu items to the left nav string
strLeftNav = strLeftNav & "
" & vbCRLF
'if the current url is equal to the url value of the current record in the rsLevel4 recordset or in one of its subsections then...
If (strCurrentURL = strLevel4ItemURL) Or bolSubsectionIsCurrentURL Then
'get the 5th level sections according to the value of the intLevel4ItemId variable
Set rsLevel5 = GetSubsections(intLevel4ItemId)
'if there are 5th level sections then...
If Not rsLevel5.Eof Then
'loop through the 5th level sections (recordset)
Do While Not rsLevel5.Eof
'increment the intLevel5MenuItemCounter variable
intLevel5MenuItemCounter = intLevel5MenuItemCounter + 1
'set the recordset values into the relevant variables
intLevel5ItemId = rsLevel5("SECTION_ID")
strLevel5ItemName = rsLevel5("SECTION_NAME_ENG")
strLevel5ItemURL = rsLevel5("URL_ENG")
strLevel5ItemClass = "fourthlevel"
'if the current url is equal to the url value of the current record in the rsLevel4 recordset then...
If strCurrentURL = strLevel5ItemURL Then
'set the intSelected5rdLevelId variable with the value of the current section id
intSelected4rdLevelId = intLevel5ItemId
'identify the link class as lit
strLevel5ItemClass = strLevel5ItemClass & "lit"
End If
'concatenate the table structure and the menu items to the left nav string
strLeftNav = strLeftNav & "
" & vbCRLF
'move to the next record in the rsLevel5 recordset
rsLevel5.MoveNext
Loop
End If
End If
'move to the next record in the rsLevel4 recordset
rsLevel4.MoveNext
Loop
End If
End If
'move to the next record in the rsLevel3 recordset
rsLevel3.MoveNext
Loop
End If
End If
'move to the next record in the rsLevel2 recordset
rsLevel2.MoveNext
Loop
'end left nav table structure
strLeftNav = strLeftNav & "
" & vbCRLF
'INSERT CONDITIONAL LOGIC TO ACCOMODATE NON-STANDARD section logic for 'Your Opinion'
'if the level1 = 115 (Your Opinion) then
If level1 = 115 Then
strLeftNav = strLeftNav & "
" & vbCRLF
Else
strLeftNav = strLeftNav & "
" & vbCRLF
End If
strLeftNav = strLeftNav & "
" & vbCRLF
strLeftNav = strLeftNav & "
" & vbCRLF
strLeftNav = strLeftNav & "
" & vbCRLF
strLeftNav = strLeftNav & "
" & vbCRLF
strLeftNav = strLeftNav & "
" & vbCRLF
strLeftNav = strLeftNav & "" & vbCRLF
End If
'release the rsLevel2 recordset from memory
rsLevel2.Close
Set rsLevel2 = Nothing
'if the rsLevel3 recordset has been initialized then...
If IsObject(rsLevel3) Then
'release the rsLevel3 recordset from memory
rsLevel3.Close
Set rsLevel3 = Nothing
End If
'if the rsLevel4 recordset has been initialized then...
If IsObject(rsLevel4) Then
'release the rsLevel4 recordset from memory
rsLevel4.Close
Set rsLevel4 = Nothing
End If
'return the left navigation string
ManageLeftNav = strLeftNav
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("ManageLeftNav", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetYearMenu function takes a posting type id and a year (4 digit) and returns a year menu system (links).
Function GetYearMenu(intPostingTypeId, intSelectedYear, strPostingPath)
On Error Resume Next
'dim strDelimiter - The strDelimiter variable is defined in the common_utils.asp file.
dim strYears
dim strYearMenu
dim strLinkURL
dim intYearCounter
dim intYearArrayCounter
dim bolSelectedYearIsValid
dim arYears
dim strClass
'set the strLinkURL variable with the URL to the postings of the selected posting type
strLinkURL = strPostingPath & "?type_id=" & intPostingTypeId & "&year="
'set the strYearMenu with an empty string
strYearMenu = ""
'set strYears with the distinct year values for all of the Postings of the selected Posting Type
strYears = GetPostingTypeYears(intPostingTypeId)
'create an array of year values from the strYears variable
arYears = Split(strYears, strDelimiter)
'verify that the selected year is valid
bolSelectedYearIsValid = SelectedYearIsValid(intPostingTypeId, intSelectedYear)
'initialize intYearCounter variable to 0
intYearCounter = 0
'set the default value for the strClass variable
strClass = "year"
'loop through each posting type year
For intYearArrayCounter = LBound(arYears) To UBound(arYears)
'if the array item is not an empty string then...
If Trim(arYears(intYearArrayCounter)) <> "" Then
'increment intYearCounter variable by 1
intYearCounter = intYearCounter + 1
'if this is the first iteration of the loop then...
If intYearCounter = 1 Then
'if the intSelectedYear parameter is not valid then...
If Not bolSelectedYearIsValid Then
'make the first year lit
strClass = "yearlit"
'if the intSelectedYear parameter is valid then...
Else
'if the current year (in the loop) is equal to the selected year then...
If (CInt(arYears(intYearArrayCounter)) = CInt(intSelectedYear)) Then
'make the selected year lit
strClass = "yearlit"
'if the current year (in the loop) is not equal to the selected year then...
Else
'make the selected year unlit
strClass = "year"
End If
End If
'if this is not the first iteration of the loop then...
Else
'concatenate two spaces to the menu
strYearMenu = strYearMenu & " | "
'if the intSelectedYear parameter is valid then...
If bolSelectedYearIsValid Then
'if the current year (in the loop) is equal to the selected year then...
If (CInt(arYears(intYearArrayCounter)) = CInt(intSelectedYear)) Then
'make the selected year lit
strClass = "yearlit"
'if the current year (in the loop) is not equal to the selected year then...
Else
'make the selected year unlit
strClass = "year"
End If
'if the intSelectedYear parameter is valid then...
Else
'make the selected year unlit
strClass = "year"
End If
End If
strYearMenu = strYearMenu & "" & arYears(intYearArrayCounter) & ""
End If
'increment intYearArrayCounter variable value by 1
Next
GetYearMenu = strYearMenu
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetYearMenu", err.number, err.description)
End If
On Error Goto 0
End Function
'The SelectedYearIsValid function takes a posting type id and year and returns true if the selected year contains any postings of the said posting type.
Function SelectedYearIsValid(intPostingTypeId, intSelectedYear)
On Error Resume Next
dim strYears
'if intSelectedYear is not in a valid format then...
If Not IsNumeric(intSelectedYear) Or Not (intSelectedYear <> "") Or Len(intSelectedYear) <> 4 Then
'set bolSelectedYearIsValid to false
SelectedYearIsValid = False
'if intSelectedYear is in a valid format then...
Else
'set strYears with the distinct year values for all of the Postings of the selected Posting Type
strYears = GetPostingTypeYears(intPostingTypeId)
'set the bolSelectedYearIsValid variable with the boolean value of the 'InStr(strYears, intSelectedYear)>0' expression
SelectedYearIsValid = CBool(InStr(strYears, intSelectedYear)>0)
End If
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("SelectedYearIsValid", err.number, err.description)
End If
On Error Goto 0
End Function
'The ManagePostings function takes a posting type id, year and path and returns a table of posting dates and titles.
Function ManagePostings(intPostingTypeId, intSelectedYear, strPostingPath, bolAdminView)
On Error Resume Next
dim rsPostings
'get postings for the selected year into rsPostings recordset variable
Set rsPostings = GetPostings(intPostingTypeId, intSelectedYear)
'if there exist postings related to the selected year and the posting type then...
If Not rsPostings.Eof Then
'return the string index (table) of postings
ManagePostings = GetPostingsIndex(rsPostings, strPostingPath, bolAdminView)
'if there does not exist postings related to the selected year and the posting type then...
Else
'let the user know that there does not exist postings of this type
ManagePostings = "
There are no Postings of this Posting Type.
"
End If
'release the recordset from memory
rsPostings.Close
Set rsPostings = Nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("ManagePostings", err.number, err.description)
End If
On Error Goto 0
End Function
'The ManageRecentPostings function takes a posting type id and returns a table of most recent (year) posting dates and titles.
Function ManageRecentPostings(intPostingTypeId, strPostingPath, bolAdminView)
On Error Resume Next
dim rsPostings
dim intSelectedYear
'get the most recent year of postings of a specific posting type (intPostingTypeId)
intSelectedYear = GetPostingsRecentYear(intPostingTypeId)
'if there exist postings related to the selected year and the posting type then...
If intSelectedYear <> "" Then
'get postings for the selected year into rsPostings recordset variable
Set rsPostings = GetPostings(intPostingTypeId, intSelectedYear)
'return the string index (table) of postings
ManageRecentPostings = GetPostingsIndex(rsPostings, strPostingPath, bolAdminView)
'release the recordset from memory
rsPostings.Close
Set rsPostings = Nothing
'if there does not exist postings related to the selected year and the posting type then...
Else
'let the user know that there does not exist postings of this type
ManageRecentPostings = "
There are no Postings of this Posting Type.
"
End If
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("ManageRecentPostings", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetPostingTypeYears function takes the posting type id and returns a delimited string of years that exist for the selected posting type.
Function GetPostingTypeYears(intPostingTypeId)
On Error Resume Next
'dim strDelimiter - The strDelimiter variable is defined in the common_utils.asp file.
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_POSTING_TYPE_YEARS"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamInput, , intPostingTypeId)
cmd.Parameters.Append cmd.CreateParameter("DELIMITER", adVarchar, adParamInput, 3, strDelimiter)
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_YEARS", adVarchar, adParamOutput, 150)
cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetPostingTypeYears", err.number, err.description)
End If
'return the delimited posting type years string
GetPostingTypeYears = cmd.Parameters("POSTING_TYPE_YEARS")
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'The GetPostings function takes the posting type id and the selected year and returns the related postings as a recordset.
Function GetPostings(intPostingTypeId, intSelectedYear)
On Error Resume Next
'dim strLanguage - The strLanguage variable is defined in the common_utils.asp file.
dim cmd
'set default value for strLanguage
strLanguage = "ENG"
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_POSTINGS"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamInput, , intPostingTypeId)
cmd.Parameters.Append cmd.CreateParameter("POSTING_YEAR", adInteger, adParamInput, , intSelectedYear)
cmd.Parameters.Append cmd.CreateParameter("LANGUAGE_ABBREVIATION", adVarchar, adParamInput, 10, strLanguage)
'return the postings records
Set GetPostings = cmd.execute
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetPostings", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetPostingsIndex function takes a recordset of postings (date and title), a path and a boolean value identifying the display as an Admin or Client interface, and returns a string index (table) of them.
Function GetPostingsIndex(rsPostings, strPostingPath, bolAdminView)
On Error Resume Next
'dim strLanguage - The strLanguage variable is defined in the common_utils.asp file.
dim strPostingsIndex
'start building the index (table) of postings
strPostingsIndex = "
" & vbCRLF
'add spacer to the strPostingsIndex variable
strPostingsIndex = strPostingsIndex & "
" & vbCRLF
'if the current posting (in the recordset) should open in a new window and is not displayed in an admin interface then...
If CBool(rsPostings("POSTING_OPENS_IN_NEW_WINDOW")) And Not bolAdminView Then
'concatenate the open_window javascript function
strPostingsIndex = strPostingsIndex & "" & rsPostings("POSTING_TITLE_" & strLanguage) & "" & vbCRLF
'if the current posting (in the recordset) should not open in a new window or is displayed in an admin interface then...
Else
'concatenate a link
strPostingsIndex = strPostingsIndex & "" & rsPostings("POSTING_TITLE_" & strLanguage) & "" & vbCRLF
End If
strPostingsIndex = strPostingsIndex & "
" & vbCRLF
'move to the next record in the recordset
rsPostings.MoveNext
Loop
'close the index (table) of postings
strPostingsIndex = strPostingsIndex & "
" & vbCRLF
'return the string index of postings
GetPostingsIndex = strPostingsIndex
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetPostingsIndex", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetSelectedPosting function takes the posting id and returns all related posting info.
Function GetSelectedPosting(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 GetSelectedPosting = cmd.execute
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetSelectedPosting", err.number, err.description)
End If
On Error Goto 0
End Function
'The SimpleDate function assures that the day and month in a date always have 2 digits.
Function SimpleDate(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
SimpleDate = strDay & "/" & strMonth & "/" & strYear
End Function
'The GetYearForPosting function takes the posting id and returns the year value associated with the related posting.
Function GetYearForPosting(intPostingId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_YEAR_FOR_POSTING"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("YEAR", adInteger, adParamOutput)
cmd.Parameters.Append cmd.CreateParameter("POSTING_ID", adInteger, adParamInput, , intPostingId)
cmd.execute
'return the posting info
GetYearForPosting = cmd.Parameters("YEAR")
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetYearForPosting", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetPostingPath function takes the display type and the posting type and returns the related path (URL).
Function GetPostingPath(intPostingTypeId, intDisplayTypeId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_POSTING_PATH"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_PATH", adVarchar, adParamOutput, 250)
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamInput, , intPostingTypeId)
cmd.Parameters.Append cmd.CreateParameter("DISPLAY_TYPE_ID", adInteger, adParamInput, , intDisplayTypeId)
cmd.execute
'return the posting path
GetPostingPath = cmd.Parameters("POSTING_PATH")
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetPostingPath", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetHomePagePostings function takes the posting id and the number of postings to display and returns an index of posting links.
Function GetHomePagePostings(intPostingTypeId, intNumberOfPostingsToDisplay)
On Error Resume Next
dim cmd
dim strHomePagePostings
dim rsPostings
dim strPostingPath
dim intDisplayTypeId
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
'set the intDisplayTypeId to 2 (index/detail page with year menu)
intDisplayTypeId = 2
'get the posting path for the selected posting type
strPostingPath = GetPostingPath(intPostingTypeId, intDisplayTypeId)
'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
'if the current posting (in the recordset) should open in a new window then...
If CBool(rsPostings("POSTING_OPENS_IN_NEW_WINDOW")) Then
'concatenate the open_window javascript function
strHomePagePostings = strHomePagePostings & "" & rsPostings("POSTING_TITLE_ENG") & "" & vbCRLF
'if the current posting (in the recordset) should not open in a new window or is displayed in an admin interface then...
Else
'if there exists a posting index of this type on the site then...
If strPostingPath <> "" Then
strHomePagePostings = strHomePagePostings & "" & rsPostings("POSTING_TITLE_ENG") & ""
Else
strHomePagePostings = strHomePagePostings & "" & rsPostings("POSTING_TITLE_ENG") & ""
End If
End If
'move to the next record in the recordset
rsPostings.MoveNext
Loop
'if there exists a posting index of this type on the site then...
If strPostingPath <> "" Then
'display the posting index link
strHomePagePostings = strHomePagePostings & "
NEWS ARCHIVE"
End If
'if there are no postings then...
Else
'alert the user
strHomePagePostings = "There are no postings at this time."
End If
'return the posting info
GetHomePagePostings = strHomePagePostings
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetHomePagePostings", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetPostingsRecentYear function takes a posting type id and returns the most recent year related to a posting of the said posting type.
Function GetPostingsRecentYear(intPostingTypeId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_POSTINGS_RECENT_YEAR"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamInput, , intPostingTypeId)
cmd.Parameters.Append cmd.CreateParameter("RECENT_YEAR", adInteger, adParamOutput)
cmd.execute
'return the recent year
GetPostingsRecentYear = cmd.Parameters("RECENT_YEAR")
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetPostingsRecentYear", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetUrl function takes a section id and returns the URL in the requested language.
Function GetUrl(intSectionId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_URL"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("SECTION_ID", adInteger, adParamInput, , intSectionId)
cmd.Parameters.Append cmd.CreateParameter("URL", adVarChar, adParamOutput, 250)
cmd.execute
'return the url
GetUrl = cmd.Parameters("URL")
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetUrl", err.number, err.description)
End If
On Error Goto 0
End Function
'This function loads XML data into an instance
'of an MSXML object. objDocument is an empty variable that will return
'a populated XML document object. bLoadSubItems is a Boolean that indicates
'whether we want our "Load on Demand" folder loaded with subitems. If
'the data is loaded successfully, the function returns TRUE, otherwise
'it returns FALSE.
Function LoadAllSections(byRef objDocument, bLoadSubItems)
dim bResult
bResult = true
on error resume next
'Create instance of XML document object that we can manipulate
Set objDocument = Server.CreateObject("MSXML2.FreeThreadedDOMDocument.3.0")
if objDocument is nothing then
Response.Write "objDocument object not created "
bResult = false
else
If Err Then
Response.Write "XML Document Object Creation Error - "
Response.write Err.Description & " "
bResult = false
else
''''''''''''''''''''''
' Declare our Objects and Variables here
'''''''''''''''''''''
dim conn, objHomeNode
dim objLevel_1_Node, objLevel_2_Node, objLevel_3_Node, objLevel_4_Node, objLevel_5_Node, objLevel_6_Node
dim rsLevel_1, rsLevel_2, rsLevel_3, rsLevel_4, rsLevel_5, rsLevel_6
dim intLevel_1, intLevel_2, intLevel_3, intLevel_4, intLevel_5, intLevel_6
on error resume next
'set the intLevel_1 variable to 0 (Web site root id value)
intLevel_1 = 0
'Create the website folder
set objHomeNode = objDocument.createElement("website") 'XML tag name
objHomeNode.setAttribute("value") = "Vitesse Web site Menus" 'Display text
objHomeNode.setAttribute("section_id") = intLevel_1 'URL for the item
objHomeNode.setAttribute("type") = "root" 'Root/Folder/Document
objHomeNode.setAttribute("url_id") = intLevel_1
objHomeNode.setAttribute("display_type_id") = 0
'get the 1st level sections according to the value of the intLevel_1 (parent id) variable
Set rsLevel_1 = GetSubsections(intLevel_1)
if not rsLevel_1.eof then
'Create a node in the XML document object for each section
do while not rsLevel_1.eof
set objLevel_1_Node = objDocument.createElement("section")
objLevel_1_Node.setAttribute("type") = "level_1"
objLevel_1_Node.setAttribute("value") = rsLevel_1("SECTION_NAME_ENG")
objLevel_1_Node.setAttribute("section_id") = rsLevel_1("SECTION_ID")
If IsNull(rsLevel_1("URL_ID")) Then
objLevel_1_Node.setAttribute("url_id") = 0
objLevel_1_Node.setAttribute("display_type_id") = 0
Else
objLevel_1_Node.setAttribute("url_id") = rsLevel_1("URL_ID")
objLevel_1_Node.setAttribute("display_type_id") = GetDisplayType(rsLevel_1("URL_ENG"))
End If
'set the intLevel_2 variable
intLevel_2 = rsLevel_1("SECTION_ID")
'get the 2nd level sections according to the value of the intLevel_2 (parent id) variable
Set rsLevel_2 = GetSubsections(intLevel_2)
if not rsLevel_2.eof then
'Create a node in the XML document object for each section
do while not rsLevel_2.eof
set objLevel_2_Node = objDocument.createElement("section")
objLevel_2_Node.setAttribute("type") = "level_2"
objLevel_2_Node.setAttribute("value") = rsLevel_2("SECTION_NAME_ENG")
objLevel_2_Node.setAttribute("section_id") = rsLevel_2("SECTION_ID")
If IsNull(rsLevel_2("URL_ID")) Then
objLevel_2_Node.setAttribute("url_id") = 0
objLevel_2_Node.setAttribute("display_type_id") = 0
Else
objLevel_2_Node.setAttribute("url_id") = rsLevel_2("URL_ID")
objLevel_2_Node.setAttribute("display_type_id") = GetDisplayType(rsLevel_2("URL_ENG"))
End If
'set the intLevel_3 variable
intLevel_3 = rsLevel_2("SECTION_ID")
'get the 3rd level sections according to the value of the intLevel_3 (parent id) variable
Set rsLevel_3 = GetSubsections(intLevel_3)
if not rsLevel_3.eof then
'Create a node in the XML document object for each section
do while not rsLevel_3.eof
set objLevel_3_Node = objDocument.createElement("section")
objLevel_3_Node.setAttribute("type") = "level_3"
objLevel_3_Node.setAttribute("value") = rsLevel_3("SECTION_NAME_ENG")
objLevel_3_Node.setAttribute("section_id") = rsLevel_3("SECTION_ID")
If IsNull(rsLevel_3("URL_ID")) Then
objLevel_3_Node.setAttribute("url_id") = 0
objLevel_3_Node.setAttribute("display_type_id") = 0
Else
objLevel_3_Node.setAttribute("url_id") = rsLevel_3("URL_ID")
objLevel_3_Node.setAttribute("display_type_id") = GetDisplayType(rsLevel_3("URL_ENG"))
End If
'set the intLevel_4 variable
intLevel_4 = rsLevel_3("SECTION_ID")
'get the 4th level sections according to the value of the intLevel_4 (parent id) variable
Set rsLevel_4 = GetSubsections(intLevel_4)
if not rsLevel_4.eof then
'Create a node in the XML document object for each section
do while not rsLevel_4.eof
set objLevel_4_Node = objDocument.createElement("section")
objLevel_4_Node.setAttribute("type") = "level_4"
objLevel_4_Node.setAttribute("value") = rsLevel_4("SECTION_NAME_ENG")
objLevel_4_Node.setAttribute("section_id") = rsLevel_4("SECTION_ID")
If IsNull(rsLevel_4("URL_ID")) Then
objLevel_4_Node.setAttribute("url_id") = 0
objLevel_4_Node.setAttribute("display_type_id") = 0
Else
objLevel_4_Node.setAttribute("url_id") = rsLevel_4("URL_ID")
objLevel_4_Node.setAttribute("display_type_id") = GetDisplayType(rsLevel_4("URL_ENG"))
End If
'set the intLevel_5 variable
intLevel_5 = rsLevel_4("SECTION_ID")
'get the 5th level sections according to the value of the intLevel_5 (parent id) variable
Set rsLevel_5 = GetSubsections(intLevel_5)
if not rsLevel_5.eof then
'Create a node in the XML document object for each section
do while not rsLevel_5.eof
set objLevel_5_Node = objDocument.createElement("section")
objLevel_5_Node.setAttribute("type") = "level_5"
objLevel_5_Node.setAttribute("value") = rsLevel_5("SECTION_NAME_ENG")
objLevel_5_Node.setAttribute("section_id") = rsLevel_5("SECTION_ID")
If IsNull(rsLevel_5("URL_ID")) Then
objLevel_5_Node.setAttribute("url_id") = 0
objLevel_5_Node.setAttribute("display_type_id") = 0
Else
objLevel_5_Node.setAttribute("url_id") = rsLevel_5("URL_ID")
objLevel_5_Node.setAttribute("display_type_id") = GetDisplayType(rsLevel_5("URL_ENG"))
End If
'set the intLevel_6 variable
intLevel_6 = rsLevel_5("SECTION_ID")
'get the 6th level sections according to the value of the intLevel_6 (parent id) variable
Set rsLevel_6 = GetSubsections(intLevel_6)
if not rsLevel_6.eof then
'Create a node in the XML document object for each section
do while not rsLevel_6.eof
set objLevel_6_Node = objDocument.createElement("section")
objLevel_6_Node.setAttribute("type") = "level_6"
objLevel_6_Node.setAttribute("value") = rsLevel_6("SECTION_NAME_ENG")
objLevel_6_Node.setAttribute("section_id") = rsLevel_6("SECTION_ID")
If IsNull(rsLevel_6("URL_ID")) Then
objLevel_6_Node.setAttribute("url_id") = 0
objLevel_6_Node.setAttribute("display_type_id") = 0
Else
objLevel_6_Node.setAttribute("url_id") = rsLevel_6("URL_ID")
objLevel_6_Node.setAttribute("display_type_id") = GetDisplayType(rsLevel_6("URL_ENG"))
End If
objLevel_5_Node.appendChild objLevel_6_Node 'Attach the new node to its parent
rsLevel_6.movenext
loop
rsLevel_6.close
end if
set rsLevel_6 = nothing
objLevel_4_Node.appendChild objLevel_5_Node 'Attach the new node to its parent
rsLevel_5.movenext
loop
rsLevel_5.close
end if
set rsLevel_5 = nothing
objLevel_3_Node.appendChild objLevel_4_Node 'Attach the new node to its parent
rsLevel_4.movenext
loop
rsLevel_4.close
end if
set rsLevel_4 = nothing
objLevel_2_Node.appendChild objLevel_3_Node 'Attach the new node to its parent
rsLevel_3.movenext
loop
rsLevel_3.close
end if
set rsLevel_3 = nothing
objLevel_1_Node.appendChild objLevel_2_Node 'Attach the new node to its parent
rsLevel_2.movenext
loop
rsLevel_2.close
end if
set rsLevel_2 = nothing
objHomeNode.appendChild objLevel_1_Node 'Attach the new node to its parent
rsLevel_1.movenext
loop
rsLevel_1.close
end if
set rsLevel_1 = nothing
'objHomeNode.appendChild objLevel_1_Node 'Attach the section node to the root item
'Now append the root node to the main document node
objDocument.appendChild objHomeNode
if err <> 0 then
Response.Write err.Description & " "
bResult = false
err = 0
end if
end if
end if
LoadAllSections = bResult
End Function
'This subroutine is the workhorse of our menu page. It is responsible for
'traversing the XML tree to display each menu item. The routine calls itself
'recursively and generates an HTML page containing javascript that handles
'showing/hiding menu items.
'[Parameters]
'--------------------
'objNodes : The XML object containing our menu data
'iElement : Passed by reference, this value increments twice each time we add
' a new menu item. The first time it increments, the value is to identify the
' menu item. The value is immediately incremented and this time is used to
' identify the element that will be shown/hidden
'sLeftIndent : Passed by reference, this string accumulates the
and tags necessary
' to display empty space and dotted lines to the left of the menu item as
' the item gets indented in the list.
'sOpenFolders : This string contains values that tell the subroutine
' which folders should be displayed as "open" by default.
Sub DisplayNode(ByVal objNodes, ByRef iElement, ByRef sLeftIndent, byRef sOpenFolders)
on error resume next
Dim oNode, sAttrValue, sNodeType, intSectionId, intUrlId, sNodeName, sMode, strDisplayTypeId
Dim NODE_ELEMENT
dim sTempLeft, bHasChildren, bIsLast, bIsRoot, bShowOpen
NODE_ELEMENT = 1
iElement = iElement + 1
For Each oNode In objNodes
'Find out if current node has children
bHasChildren = oNode.hasChildNodes
'Find out if the current node is the last member
'in the list or not
if not(oNode.nextSibling is nothing) then
bIsLast = false
else
bIsLast = true
end if
'Ignore NODE_TEXT node types
if oNode.nodeType = NODE_ELEMENT Then
sNodeName = oNode.nodeName
sAttrValue = oNode.getAttribute("value") 'Get the display value of the current node
sNodeType = lcase(oNode.getAttribute("type")) 'Get the type of the current node Folder/Document
intSectionId = oNode.getAttribute("section_id")
intUrlId = oNode.getAttribute("url_id")
strDisplayTypeId = oNode.getAttribute("display_type_id")
'Find out if this is the root of the tree
if (sNodeType = "root") then
bIsRoot = true
else
bIsRoot = false
end if
if (sNodeType = "document") then
%>
<%
Response.write sLeftIndent 'Display the proper indentation formatting
'Now display the document node
%>
<%Response.Write vbCRLF
else 'Otherwise this is a folder
%>
<%
'Check if we are building the tree for the first time
if (sNodeType = "root") then
bShowOpen = true 'We want the root folder open by default
else
If sOpenFolders <> "" Then
bShowOpen = fnGetFolderStatus(intSectionId, sOpenFolders)
Else
bShowOpen = false
End If
end if
Response.write sLeftIndent 'Display the proper indentation formatting
'Now display the folder
%>
<%Response.Write vbCRLF
'Increment the element ID
iElement = iElement + 1
'After displaying the folder, let's see
'if it contains any submenu items
If bHasChildren Then
%>
<%Response.Write vbCRLF
'First store the indentation code
sTempLeft = sLeftIndent
'We don't want to indent the first node on our tree
'so only generate indent code if this not the root menu item
if (iElement > 1) then
sLeftIndent = fnBuildLeftIndent(oNode, bIsLast, sLeftIndent)
end if
'Call this subroutine again to process the submenu item
DisplayNode oNode.childNodes, iElement, sLeftIndent, sOpenFolders
'We're popping the stack, so reset the value of sLeftIndent
'to what it was before we went into the DisplayNode() subroutine above
sLeftIndent = sTempLeft%>
<%
End If
end if
End If
Next
'Display any error messages encountered while executing this subroutine
if err <> 0 then
Response.Write err.description & " "
end if
End Sub
'This function returns the appropriate icon to be displayed in the menu. It decides
'which icon to return based on the parameters that are passed in.
'[Parameters]
'--------------------
'bIsLast : TRUE/FALSE - is this the last child in the current list?
'bIsRoot : TRUE/FALSE - is this the root node of the tree?
'sNodeType : String containing "document", "folder", or "root".
'bHasChildren : TRUE/FALSE - specifies if the current item has any children
'bShowOpen : TRUE/FALSE - specifies if we want the folder open or closed icon displayed
function fnChooseIcon(byval bIsLast, byval bIsRoot, byval sNodeType, byval bHasChildren, byval bShowOpen)
dim sIcon
sIcon = ""
if (sNodeType = "document") then
if (bIsLast = false) then
sIcon = "docjoin.gif" 'This is not the last document in list, so use JOIN graphic
else
sIcon = "doc.gif" 'This is the last document on the list so use the DOC angle graphic
end if
else
if (bIsRoot = true) then
'Root item requires special icon
if (bShowOpen = true) then
sIcon = "minusonly.gif"
else
sIcon = "plusonly.gif"
end if
elseif (bHasChildren = true) then
'Folder has children, so use default folder open icon
if (bShowOpen = true) then
sIcon = "folderopen.gif"
else
sIcon = "folderclosed.gif"
end if
elseif (bHasChildren = false) then
'Folder does NOT have children, so first check
'what order it is in the list
if (bIsLast = false) then
'Not the last member, so use an empty folder with a line join graphic
sIcon = "folderclosedjoin-empty.gif"
else
'Is the last member, so use an empty folder with a line angle graphic
sIcon = "folderclosed-empty.gif"
end if
end if
end if
fnChooseIcon = sIcon
end function
'This function builds the html code necessary for indenting the menu
'item. This includes any graphics that may be necessary for showing
'a continuation of a dotted line. The new string is returned by the function.
'[Parameters]
'--------------------
'oNode : Object reference for a node
'bIsLast : TRUE/FALSE - Is this the last child in the list?
'sLeftIndent : String containing the html code for indenting the item
function fnBuildLeftIndent(byval oNode, byval bIsLast, byVal sLeftIndent)
'Check to see if this node is the last on the
'list or if it has more siblings. We set up our indent
'accordingly. We need to set this up before displaying
'any of the node's children.
if (bIsLast = false) then
'This node is not the last on the list, so we need to create
'an indent that contains a dotted line.
sLeftIndent = sLeftIndent & "
"
else
'Otherwise it is the last on the list so we just need to
'display a blank space
sLeftIndent = sLeftIndent & "
"
end if
fnBuildLeftIndent = sLeftIndent
end function
'Determines whether a folder needs to be displayed as Open or not.
'If the value of the iID is present in the hidden
'field that contains the IDs of all open folders, then we know
'it should be Open. Returns TRUE if folder should be open,
'otherwise FALSE is returned
function fnGetFolderStatus(iID, sOpenFolders)
dim bReturn, sValue
bReturn = false
if (instr(sOpenFolders, ("," & CStr(iID) & ","))) then
bReturn = true
end if
fnGetFolderStatus = bReturn
end function
'The ReadPage function reads the body of the specified file and returns it as a string.
Function ReadPage(strPath)
On Error Resume Next
dim objFileSystem, objTextStream
'set the web site's physical path (as found on the hosting server) into the strPath variable
strPath = Server.MapPath(Replace(strPath, "/", Chr(92)))
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objTextStream = objFileSystem.OpenTextFile(strPath, 1, false)
ReadPage = objTextStream.ReadAll
objTextStream.close
Set objTextStream = Nothing
Set objFileSystem = Nothing
'if an error has occured report it
If err.number <> 0 Then
'test
response.write "strPath : " & strPath & " "
Call ReportError("ReadPage", err.number, err.description)
End If
On Error GoTo 0
End Function
'The CreatePage takes a URL and body (content) and creates a file at that address.
Sub CreatePage(strURL, strPageBody)
On Error Resume Next
dim objFileSystem, objFile
'get the path of the new file to be created into the strPath variable
strURL = Server.MapPath(Left(strURL, InStrRev(strURL, Chr(92)))) & Chr(92) & Right(strURL, (Len(strURL)-InStrRev(strURL, Chr(92))))
'create the file system and file objects
Set objFileSystem = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFileSystem.CreateTextFile(strURL)
'write the new page's content
objFile.WriteLine(strPageBody)
'close the file object
objFile.close
'release the objects from memory
Set objFile = Nothing
Set objFileSystem = Nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("CreatePage", err.number, err.description)
End If
On Error GoTo 0
End Sub
'The GetFolders function takes a path and returns a list of the folders it contains.
Function GetFolders(strRoot)
On Error Resume Next
dim objFileSystem, objFolder, colFolders, colSubFolders, objSubFolder
dim strFolderList, intFolderCounter
dim strParentFolder, strFoldersToExclude
'dim strDelimiter is defined in the common_utils.asp file
'set strFolderList variable default value (empty string)
strFolderList = ""
'set strParentFolder with value of parent folder
strParentFolder = strRoot
'concatenate list of folders to exclude
strFoldersToExclude = strDelimiter & "admin" & strDelimiter & "images" & strDelimiter & "includes" & strDelimiter & "styles" & strDelimiter
'get the full path into the strRoot variable
strRoot = Server.MapPath(strRoot) & "/"
'set the objects
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSystem.GetFolder(strRoot)
Set colFolders = objFolder.SubFolders
'set default value of intFolderCounter (0)
intFolderCounter = 0
'loop through the subfolders collection
For Each objSubFolder in colFolders
If Not (InStr(strFoldersToExclude, (strDelimiter & objSubFolder.Name & strDelimiter)) > 0) Then
If intFolderCounter <> 0 Then
strFolderList = strFolderList & strDelimiter
End If
'if the value of the strParentFolder variable is different than a backslash then...
If strParentFolder <> Chr(92) Then
'concatenate a backslash to the strParentFolder variable value
strFolderList = strFolderList & strParentFolder & Chr(92) & objSubFolder.Name
Else
strFolderList = strFolderList & strParentFolder & objSubFolder.Name
End If
Set colSubFolders = objSubFolder.SubFolders
If colSubFolders.Count > 0 Then
'if the value of the strParentFolder variable is different than a backslash then...
If strParentFolder <> Chr(92) Then
'concatenate a double backslash to the strParentFolder variable value
strFolderList = strFolderList & strDelimiter & GetFolders(strParentFolder & Chr(92) & objSubFolder.Name)
Else
strFolderList = strFolderList & strDelimiter & GetFolders(strParentFolder & objSubFolder.Name)
End If
End If
'increment the intFolderCounter variable by 1
intFolderCounter = intFolderCounter + 1
End If
Next
'release the objects from memory
If IsObject(colSubFolders) Then
Set colSubFolders = Nothing
End If
Set objFileSystem = Nothing
Set objFolder = Nothing
Set colFolders = Nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetFolders", err.number, err.description)
End If
'return delimited list of folders
GetFolders = strFolderList
On Error GoTo 0
End Function
'The GetFolderOptionList function takes the root folder (for which every subfolder will be returned as an option list string) and the folder name which is the selected item in the option list.
Function GetFolderOptionList(strRoot, strFolder)
On Error Resume Next
'dim strDelimiter is defined in the common_utils.asp file
dim arFolders
dim strFolderOptionList
dim intFolderCounter
'get delimited folder list into the arFolders variable
arFolders = Split(GetFolders(strRoot), strDelimiter)
'set default value of strFolderOptionList variable (empty string)
strFolderOptionList = ""
'loop through the arFolders array...
For intFolderCounter = LBound(arFolders) To UBound(arFolders)
'if the current item in the array is not an empty string then...
If Trim(arFolders(intFolderCounter)) <> "" Then
strFolderOptionList = strFolderOptionList & "" & vbCRLF
End If
'increment the intFolderCounter counter
Next
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetFolderList", err.number, err.description)
End If
'return option list of folders
GetFolderOptionList = strFolderOptionList
On Error GoTo 0
End Function
'The ReadSecondLevelPage function reads the content of the default 2nd level page and returns it as a string.
Function ReadSecondLevelPage()
'dim str2ndLevelTemplatePath - The str2ndLevelTemplatePath variable is defined in the common_utils.asp
ReadSecondLevelPage = ReadPage(str2ndLevelTemplatePath)
End Function
'The GetFileOptionList function takes a folder (for which every file contained within will be returned as an option list string) and the file name which is the selected item in the option list.
Function GetFileOptionList(strFolder, strFile, strExtensionsToLookFor)
On Error Resume Next
'dim strDelimiter is defined in the common_utils.asp file
dim arFiles
dim strFileOptionList
dim intFileCounter
'get delimited file list into the arFiles variable
arFiles = Split(GetFiles(strFolder, strFile, strExtensionsToLookFor), strDelimiter)
'set default value of strFileOptionList variable (empty string)
strFileOptionList = ""
'loop through the arFiles array...
For intFileCounter = LBound(arFiles) To UBound(arFiles)
'if the current item in the array is not an empty string then...
If Trim(arFiles(intFileCounter)) <> "" Then
strFileOptionList = strFileOptionList & "" & vbCRLF
End If
'increment the intFileCounter counter
Next
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetFileOptionList", err.number, err.description)
End If
'return option list of files
GetFileOptionList = strFileOptionList
On Error GoTo 0
End Function
'The GetFiles function takes a folder and returns the list of files it contains.
Function GetFiles(strFolder, strFile, strExtensionsToLookFor)
On Error Resume Next
dim objFileSystem, objFolder, objFile
dim strFileList, intFileCounter
dim strFileExtensionsToExclude
dim arAllowedExtensions
dim intExtensionCounter
'dim strDelimiter is defined in the common_utils.asp file
'set the strFileList variable value (empty string)
strFileList = ""
'set default value of intFileCounter (0)
intFileCounter = 0
'set the arAllowedExtensions variable with the array of accepted files extensions
arAllowedExtensions = Split(strExtensionsToLookFor, strDelimiter)
'set the objects
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSystem.GetFolder(Server.MapPath(strFolder & "/"))
'loop through the files collection
For Each objFile in objFolder.Files
'if this is the first iteration in the files collection
If intFileCounter <> 0 Then
strFileList = strFileList & strDelimiter
End If
'loop through all of the allowed file extensions
For intExtensionCounter = LBound(arAllowedExtensions) To UBound(arAllowedExtensions)
'if the current array element is not an empty string then...
If Trim(arAllowedExtensions(intExtensionCounter)) <> "" Then
'if the file extension is the same as that of the current file object then...
If arAllowedExtensions(intExtensionCounter) = Right(objFile.Name, (Len(objFile.Name) - InStrRev(objFile.Name, ".")+1)) Then
'concatenate the file name to the file list
strFileList = strFileList & objFile.Name
End If
End If
Next
'increment intFileCounter by 1
intFileCounter = intFileCounter + 1
'get the next file object
Next
'release the objects from memory
Set objFileSystem = Nothing
Set objFolder = Nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetFiles", err.number, err.description)
End If
'return delimited list of files
GetFiles = strFileList
On Error GoTo 0
End Function
'The GetSearchResultsIndex takes a delimited list of search criteria and the char delimiter and returns an index (recordset) of the related search results.
Function GetSearchResultsIndex(strCriteria)
On Error Resume Next
dim strSeparator
'initialize strSeperator to an empty string
strSeparator = " "
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_SITE_SEARCH_RESULTS"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("separator", adChar, adParamInput, 1, strSeparator)
cmd.Parameters.Append cmd.CreateParameter("Array", adVarchar, adParamInput, 500, strCriteria)
'return the search results
Set GetSearchResultsIndex = cmd.execute
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetSearchResultsIndex", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetSearchResultsDisplay function takes a recordset of search results and returns the HTML display of the search results.
Function GetSearchResultsDisplay(strCriteria)
On Error Resume Next
dim rsSearchResults
dim strSearchResults
dim strPostingId
dim strSearchResultLink
dim intResultCounter
dim strAbstract
dim bolURLopensInNewWindow
dim strDomainName
'get the domain name into the strDomainName variable
strDomainName = Request.ServerVariables("REMOTE_HOST")
'get the index of search results into the rsSearchResults recordset
Set rsSearchResults = GetSearchResultsIndex(strCriteria)
'initialize the strSearchResults variable to an empty string
strSearchResults = "Search Results for: " & strCriteria
'if there are search results returned for the submitted strCriteria then...
If Not rsSearchResults.Eof Then
'initialize intResultCounter to 0
intResultCounter = 0
'loop through every record in the search result recordset until there are none
Do While Not rsSearchResults.Eof
'increment intResultCounter
intResultCounter = intResultCounter + 1
'get the text related to the search criteria
strAbstract = Left(stripHTML(rsSearchResults("URL_BODY")), 250) & "..."
'if the posting id is not null then...
If Not IsNull(rsSearchResults("URL_POSTING_ID")) Then
'set strPostingId with the appropriate query string value
strPostingId = "?id=" & rsSearchResults("URL_POSTING_ID")
'if the posting id is not null then...
Else
'set strPostingId to an empty string
strPostingId = ""
End If
'if the "URL_OPENS_IN_NEW_WINDOW" value is null then...
If IsNull(rsSearchResults("URL_OPENS_IN_NEW_WINDOW")) Then
'set the bolURLopensInNewWindow variable to false
bolURLopensInNewWindow = False
'if the "URL_OPENS_IN_NEW_WINDOW" value is not null then...
Else
'set the bolURLopensInNewWindow variable to the boolean value of "URL_OPENS_IN_NEW_WINDOW"
bolURLopensInNewWindow = CBool(rsSearchResults("URL_OPENS_IN_NEW_WINDOW"))
End If
'if the url does open in a new window then...
If bolURLopensInNewWindow Then
'mark up the url title with a javascript call to open it in a new window
strSearchResultLink = "" & rsSearchResults("URL_TITLE") & ""
Else
'mark up the url title with its appropriate url
strSearchResultLink = "" & rsSearchResults("URL_TITLE") & ""
End If
'set the strSearchResults variable with the HTML string of search results
strSearchResults = strSearchResults & "
" & vbCRLF
strSearchResults = strSearchResults & intResultCounter & ". " & strSearchResultLink & " " & vbCRLF
'if the url does not open in a new window then...
If Not bolURLopensInNewWindow Then
'add the abstract to the HTML search result output
strSearchResults = strSearchResults & strAbstract & " " & vbCRLF
End If
'add the abstract to the HTML search result output
strSearchResults = strSearchResults & "" & strDomainName & rsSearchResults("URL_ENG") & strPostingId & " " & vbCRLF
strSearchResults = strSearchResults & "
" & vbCRLF
'go to the next record in the recordset
rsSearchResults.MoveNext
Loop
'if there are no search results returned for the submitted strCriteria then...
Else
'alert the user that there are no results for the criteria submitted
strSearchResults = strSearchResults & "
There are no results for the submitted search string.
"
End If
'release the rsSearchResults recordset from memory
rsSearchResults.Close
Set rsSearchResults = Nothing
'return the search results
GetSearchResultsDisplay = strSearchResults
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetSearchResultsDisplay", err.number, err.description)
End If
On Error Goto 0
End Function
'The stripHTML function takes the html code and returns the code stripped of its tags.
Function stripHTML(strHTML)
'Strips the HTML tags from strHTML using split and join
'Ensure that strHTML contains something
If len(strHTML) = 0 then
stripHTML = strHTML
Exit Function
End If
dim arysplit, i, j, strOutput
arysplit = split(strHTML, "<")
'Assuming strHTML is nonempty, we want to start iterating
'from the 2nd array postition
if len(arysplit(0)) > 0 then j = 1 else j = 0
'Loop through each instance of the array
for i=j to ubound(arysplit)
'Do we find a matching > sign?
if instr(arysplit(i), ">") then
'If so, snip out all the text between the start of the string
'and the > sign
arysplit(i) = mid(arysplit(i), instr(arysplit(i), ">") + 1)
else
'Ah, the < was was nonmatching
arysplit(i) = "<" & arysplit(i)
end if
next
'Rejoin the array into a single string
strOutput = join(arysplit, "")
'Snip out the first <
strOutput = mid(strOutput, 2-j)
'Convert < and > to < and >
strOutput = replace(strOutput,">",">")
strOutput = replace(strOutput,"<","<")
stripHTML = strOutput
End Function
'The GetDisplayType function takes a url and returns its display type as an integer.
Function GetDisplayType(strURL)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_DISPLAY_TYPE"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("URL_ENG", adVarChar, adParamInput, 250, strURL)
cmd.Parameters.Append cmd.CreateParameter("DISPLAY_TYPE_ID", adInteger, adParamOutput)
cmd.execute
'return the display type
GetDisplayType = cmd.Parameters("DISPLAY_TYPE_ID")
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetDisplayType", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetDisplayTypeCodePath function takes the display type id and returns the path to the content display code.
Function GetDisplayTypeCodePath(intDisplayTypeId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_DISPLAY_TYPE_CODE_PATH"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("DISPLAY_TYPE_ID", adInteger, adParamInput, , intDisplayTypeId)
cmd.Parameters.Append cmd.CreateParameter("DISPLAY_TYPE_CODE_PATH", adVarchar, adParamOutput, 250)
cmd.execute
'return the display type's code path
GetDisplayTypeCodePath = cmd.Parameters("DISPLAY_TYPE_CODE_PATH")
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetDisplayTypeCodePath", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetPostingTypeId function takes a URL and returns its posting type id as an integer.
Function GetPostingTypeId(strCurrentURL)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_POSTING_TYPE"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("URL_ENG", adVarchar, adParamInput, 250, strCurrentURL)
cmd.Parameters.Append cmd.CreateParameter("POSTING_TYPE_ID", adInteger, adParamOutput)
cmd.execute
'return the posting type id
GetPostingTypeId = 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 ReportError("GetPostingTypeId", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetPostingTypes function returns a recordset of posting types.
Function GetPostingTypes()
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_POSTING_TYPES"
cmd.CommandType = adCmdStoredProc
'return the posting types
Set GetPostingTypes = cmd.execute
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetPostingTypes", err.number, err.description)
End If
On Error Goto 0
End Function
'The DisplayPostingTypeCheckboxes function returns a string containing HTML (Posting Types checkboxes)
Function DisplayPostingTypeCheckboxes()
On Error Resume Next
'dim strDelimiter is defined in the common_utils.asp file
dim rsPostingTypes
dim strPostingTypesCheckboxes
dim intPostingTypeId
dim strPostingTypeName
dim intCheckboxCounter
dim intMaxCheckboxPerRox
'get the recordset of posting types into rsPostingTypes
Set rsPostingTypes = GetPostingTypes()
'set default value of intCheckboxCounter variable (0)
intCheckboxCounter = 0
'set default value of strPostingTypesCheckboxes variable (empty string)
strPostingTypesCheckboxes = ""
'set the value for the maximum number of checkboxes per row
intMaxCheckboxPerRox = 3
'if the recordset is not empty then...
If Not rsPostingTypes.Eof Then
'start building the HTML table (for the checkboxes)
strPostingTypesCheckboxes = strPostingTypesCheckboxes & "
" & vbCRLF
'loop through the rsPostingTypes recordset...
Do While Not rsPostingTypes.Eof
'if the current posting type is subscribeable then...
If CBool(rsPostingTypes("POSTING_TYPE_USER_CAN_SUBSCRIBE")) Then
'increment intCheckboxCounter by 1
intCheckboxCounter = intCheckboxCounter + 1
'add the checkbox
strPostingTypesCheckboxes = strPostingTypesCheckboxes & "
" & vbCRLF
'if the ordinal for the current checkbox is the last to appear in its row then...
If (intCheckboxCounter Mod intMaxCheckboxPerRox = 0) Then
'create a new row
strPostingTypesCheckboxes = strPostingTypesCheckboxes & "
" & vbCRLF
End If
End If
'go to the next record in the rsPostingTypes recordset
rsPostingTypes.MoveNext
Loop
If Not(intCheckboxCounter Mod intMaxCheckboxPerRox = 0) Then
For intCheckboxCounter = 1 To (intMaxCheckboxPerRox - Abs(intCheckboxCounter Mod intMaxCheckboxPerRox))
'add empty table cells
strPostingTypesCheckboxes = strPostingTypesCheckboxes & "
" & vbCRLF
Next
End If
'close the HTML table (for the checkboxes)
strPostingTypesCheckboxes = strPostingTypesCheckboxes & "
" & vbCRLF
End If
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("DisplayPostingTypeCheckboxes", err.number, err.description)
End If
'return checkboxes of posting types
DisplayPostingTypeCheckboxes = strPostingTypesCheckboxes
On Error GoTo 0
End Function
'The GetSubsectionsOrderByName function takes a section id and returns its subsections as a recordset ordered by name.
Function GetSubsectionsOrderByName(intParentId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_CHILD_SECTIONS_ORDER_BY_NAME"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("PARENT_ID", adInteger, adParamInput, , intParentId)
Set GetSubsectionsOrderByName = cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetSubsectionsOrderByName", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'This function loads XML data into an instance
'of an MSXML object. objDocument is an empty variable that will return
'a populated XML document object. bLoadSubItems is a Boolean that indicates
'whether we want our "Load on Demand" folder loaded with subitems. If
'the data is loaded successfully, the function returns TRUE, otherwise
'it returns FALSE.
Function LoadSectionsThatCanHaveChildren(byRef objDocument, bLoadSubItems)
dim bResult
bResult = true
on error resume next
'Create instance of XML document object that we can manipulate
Set objDocument = Server.CreateObject("MSXML2.FreeThreadedDOMDocument.3.0")
if objDocument is nothing then
Response.Write "objDocument object not created "
bResult = false
else
If Err Then
Response.Write "XML Document Object Creation Error - "
Response.write Err.Description & " "
bResult = false
else
''''''''''''''''''''''
' Declare our Objects and Variables here
'''''''''''''''''''''
dim conn, objHomeNode
dim objLevel_1_Node, objLevel_2_Node, objLevel_3_Node, objLevel_4_Node, objLevel_5_Node
dim rsLevel_1, rsLevel_2, rsLevel_3, rsLevel_4, rsLevel_5
dim intLevel_1, intLevel_2, intLevel_3, intLevel_4, intLevel_5
on error resume next
'set the intLevel_1 variable to 0 (Web site root id value)
intLevel_1 = 0
'Create the website folder
set objHomeNode = objDocument.createElement("website") 'XML tag name
objHomeNode.setAttribute("value") = "Vitesse Web site Menus" 'Display text
objHomeNode.setAttribute("section_id") = intLevel_1 'URL for the item
objHomeNode.setAttribute("type") = "root" 'Root/Folder/Document
objHomeNode.setAttribute("url_id") = intLevel_1
objHomeNode.setAttribute("display_type_id") = 0
'get the 1st level sections according to the value of the intLevel_1 (parent id) variable
Set rsLevel_1 = GetSubsections(intLevel_1)
if not rsLevel_1.eof then
'Create a node in the XML document object for each section
do while not rsLevel_1.eof
set objLevel_1_Node = objDocument.createElement("section")
objLevel_1_Node.setAttribute("type") = "level_1"
objLevel_1_Node.setAttribute("value") = rsLevel_1("SECTION_NAME_ENG")
objLevel_1_Node.setAttribute("section_id") = rsLevel_1("SECTION_ID")
If IsNull(rsLevel_1("URL_ID")) Then
objLevel_1_Node.setAttribute("url_id") = 0
objLevel_1_Node.setAttribute("display_type_id") = 0
Else
objLevel_1_Node.setAttribute("url_id") = rsLevel_1("URL_ID")
objLevel_1_Node.setAttribute("display_type_id") = GetDisplayType(rsLevel_1("URL_ENG"))
End If
'set the intLevel_2 variable
intLevel_2 = rsLevel_1("SECTION_ID")
'get the 2nd level sections according to the value of the intLevel_2 (parent id) variable
Set rsLevel_2 = GetSubsections(intLevel_2)
if not rsLevel_2.eof then
'Create a node in the XML document object for each section
do while not rsLevel_2.eof
set objLevel_2_Node = objDocument.createElement("section")
objLevel_2_Node.setAttribute("type") = "level_2"
objLevel_2_Node.setAttribute("value") = rsLevel_2("SECTION_NAME_ENG")
objLevel_2_Node.setAttribute("section_id") = rsLevel_2("SECTION_ID")
If IsNull(rsLevel_2("URL_ID")) Then
objLevel_2_Node.setAttribute("url_id") = 0
objLevel_2_Node.setAttribute("display_type_id") = 0
Else
objLevel_2_Node.setAttribute("url_id") = rsLevel_2("URL_ID")
objLevel_2_Node.setAttribute("display_type_id") = GetDisplayType(rsLevel_2("URL_ENG"))
End If
'set the intLevel_3 variable
intLevel_3 = rsLevel_2("SECTION_ID")
'get the 3rd level sections according to the value of the intLevel_3 (parent id) variable
Set rsLevel_3 = GetSubsections(intLevel_3)
if not rsLevel_3.eof then
'Create a node in the XML document object for each section
do while not rsLevel_3.eof
set objLevel_3_Node = objDocument.createElement("section")
objLevel_3_Node.setAttribute("type") = "level_2"
objLevel_3_Node.setAttribute("value") = rsLevel_3("SECTION_NAME_ENG")
objLevel_3_Node.setAttribute("section_id") = rsLevel_3("SECTION_ID")
If IsNull(rsLevel_3("URL_ID")) Then
objLevel_3_Node.setAttribute("url_id") = 0
objLevel_3_Node.setAttribute("display_type_id") = 0
Else
objLevel_3_Node.setAttribute("url_id") = rsLevel_3("URL_ID")
objLevel_3_Node.setAttribute("display_type_id") = GetDisplayType(rsLevel_3("URL_ENG"))
End If
'set the intLevel_4 variable
intLevel_4 = rsLevel_3("SECTION_ID")
'get the 4th level sections according to the value of the intLevel_4 (parent id) variable
Set rsLevel_4 = GetSubsections(intLevel_4)
if not rsLevel_4.eof then
'Create a node in the XML document object for each section
do while not rsLevel_4.eof
set objLevel_4_Node = objDocument.createElement("section")
objLevel_4_Node.setAttribute("type") = "level_4"
objLevel_4_Node.setAttribute("value") = rsLevel_4("SECTION_NAME_ENG")
objLevel_4_Node.setAttribute("section_id") = rsLevel_4("SECTION_ID")
If IsNull(rsLevel_4("URL_ID")) Then
objLevel_4_Node.setAttribute("url_id") = 0
objLevel_4_Node.setAttribute("display_type_id") = 0
Else
objLevel_4_Node.setAttribute("url_id") = rsLevel_4("URL_ID")
objLevel_4_Node.setAttribute("display_type_id") = GetDisplayType(rsLevel_4("URL_ENG"))
End If
'set the intLevel_5 variable
intLevel_5 = rsLevel_4("SECTION_ID")
'get the 5th level sections according to the value of the intLevel_5 (parent id) variable
Set rsLevel_5 = GetSubsections(intLevel_5)
if not rsLevel_5.eof then
'Create a node in the XML document object for each section
do while not rsLevel_5.eof
set objLevel_5_Node = objDocument.createElement("section")
objLevel_5_Node.setAttribute("type") = "level_5"
objLevel_5_Node.setAttribute("value") = rsLevel_5("SECTION_NAME_ENG")
objLevel_5_Node.setAttribute("section_id") = rsLevel_5("SECTION_ID")
If IsNull(rsLevel_5("URL_ID")) Then
objLevel_5_Node.setAttribute("url_id") = 0
objLevel_5_Node.setAttribute("display_type_id") = 0
Else
objLevel_5_Node.setAttribute("url_id") = rsLevel_5("URL_ID")
objLevel_5_Node.setAttribute("display_type_id") = GetDisplayType(rsLevel_5("URL_ENG"))
End If
objLevel_4_Node.appendChild objLevel_5_Node 'Attach the new node to its parent
rsLevel_5.movenext
loop
rsLevel_5.close
end if
set rsLevel_5 = nothing
objLevel_3_Node.appendChild objLevel_4_Node 'Attach the new node to its parent
rsLevel_4.movenext
loop
rsLevel_4.close
end if
set rsLevel_4 = nothing
objLevel_2_Node.appendChild objLevel_3_Node 'Attach the new node to its parent
rsLevel_3.movenext
loop
rsLevel_3.close
end if
set rsLevel_3 = nothing
objLevel_1_Node.appendChild objLevel_2_Node 'Attach the new node to its parent
rsLevel_2.movenext
loop
rsLevel_2.close
end if
set rsLevel_2 = nothing
objHomeNode.appendChild objLevel_1_Node 'Attach the new node to its parent
rsLevel_1.movenext
loop
rsLevel_1.close
end if
set rsLevel_1 = nothing
'objHomeNode.appendChild objLevel_1_Node 'Attach the section node to the root item
'Now append the root node to the main document node
objDocument.appendChild objHomeNode
if err <> 0 then
Response.Write err.Description & " "
bResult = false
err = 0
end if
end if
end if
LoadSectionsThatCanHaveChildren = bResult
End Function
Function GetSubsectionsThatCanHaveChildren(intParentId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_SECTIONS_THAT_CAN_HAVE_CHILDREN"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("PARENT_ID", adInteger, adParamInput, , intParentId)
Set GetSubsectionsThatCanHaveChildren = cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetSubsectionsThatCanHaveChildren", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
Function GetSubsectionsWithURL(intParentId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_CHILD_SECTIONS_WITH_URL"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("PARENT_ID", adInteger, adParamInput, , intParentId)
Set GetSubsectionsWithURL = cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetSubsectionsWithURL", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'The GetCountryOptionList function takes a country id and returns an option list of countries and selects the submitted country.
Function GetCountryOptionList(intCountryId, bolByName)
On Error Resume Next
dim rsCountry
dim strCountryOptionList
'get recordset of countries into the rsCountry recordset object
Set rsCountry = GetCountries()
'set default value of strCountryOptionList variable (empty string)
strCountryOptionList = ""
'loop through the rsCountry recordset...
Do While Not rsCountry.Eof
If bolByName = True Then
'concatenate the values in the rsCountry recordset to the strCountryOptionList variable
strCountryOptionList = strCountryOptionList & "" & vbCRLF
'go to the next record in rsCountry
rsCountry.MoveNext
Loop
'release the recordset from memory
rsCountry.Close
Set rsCountry = Nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetCountryOptionList", err.number, err.description)
End If
'return option list of folders
GetCountryOptionList = strCountryOptionList
On Error GoTo 0
End Function
'The GetCountries function returns the a recordset of countries in alphabetical order.
Function GetCountries()
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_COUNTRIES"
cmd.CommandType = adCmdStoredProc
'return the recordset
Set GetCountries = cmd.execute
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetCountries", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetCountryName function takes a country id and returns its name.
Function GetCountryName(intCountryId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_COUNTRY_NAME"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("COUNTRY_NAME", adVarchar, adParamOutput, 250)
cmd.Parameters.Append cmd.CreateParameter("COUNTRY_ID", adInteger, adParamInput, , intCountryId)
cmd.execute
'return the country name
GetCountryName = cmd.Parameters("COUNTRY_NAME")
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetCountryName", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetAlphabeticalMenu function takes the subscriber type, the # of items displayed per page, the module name and returns an html alphabetical menu.
Function GetAlphabeticalMenu(strSubscriberType, strCurrentModule, intItemsDisplayedPerPage)
On Error Resume Next
dim strPath
dim strAlphabeticalMenu
dim intSubscriberCountSubTotal
dim intLetterCounter
dim arAlphabetList
dim intPageNumber
'set the strAlphabeticalMenu variable with default value (empty string)
strAlphabeticalMenu = ""
'set the path according to the admin module in question
Select Case LCase(strCurrentModule)
'if the current module is the 'subscribers' module then...
Case "subscriber"
'set the strPath variable with the path to the subscribers admin page
strPath = "/admin/subscribers.asp?type=" & strSubscriberType & "&"
'if the current module is the 'url' module then...
Case "url"
'set the strPath variable with the path to the subscribers admin page
strPath = "/admin/urls.asp?"
End Select
'concatenate the page querystring value to the path
strPath = strPath & "page="
'get the list of distinct first letters for subscriber last names into the arAlphabetList
arAlphabetList = Split(GetSubscriberAlphabetList(), ", ")
intSubscriberCountSubTotal = 1
'loop through the list of distinct first letters for subscriber last names and add them to the menu system
For intLetterCounter = LBound(arAlphabetList) To UBound(arAlphabetList)
'if the array element is not an empty string then...
If Trim(arAlphabetList(intLetterCounter)) <> "" Then
'set the page number
intPageNumber = Fix(((intSubscriberCountSubTotal + 1) / intItemsDisplayedPerPage) + 1)
'intPageNumber = (intSubscriberCountSubTotal / intItemsDisplayedPerPage)
'concatenate the letter to the menu system
strAlphabeticalMenu = strAlphabeticalMenu & "[" & arAlphabetList(intLetterCounter) & "]"
'concatenate a space between menu items
strAlphabeticalMenu = strAlphabeticalMenu & " " & vbCRLF
'get the number of subscribers for the selected letter
intSubscriberCountSubTotal = intSubscriberCountSubTotal + GetSubscriberCountPerLetter(arAlphabetList(intLetterCounter))
End If
Next
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetAlphabeticalMenu", err.number, err.description)
End If
'return the page menu
GetAlphabeticalMenu = strAlphabeticalMenu
On Error Goto 0
End Function
'The GetSubscriberAlphabetList function returns the a recordset of distinct first letters of subscriber last names in alphabetical order.
Function GetSubscriberAlphabetList()
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_SUBSCRIBER_ALPHABET_LIST"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("FIRST_LETTER_LIST", adVarchar, adParamOutput, 500)
cmd.execute
'return the recordset
GetSubscriberAlphabetList = cmd.Parameters("FIRST_LETTER_LIST")
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetSubscriberAlphabetList", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetSubscriberCountPerLetter function returns the a recordset of distinct first letters of subscriber last names in alphabetical order.
Function GetSubscriberCountPerLetter(strLetter)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_SUBSCRIBER_COUNT_FIRST_LETTER"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_COUNT", adInteger, adParamOutput)
cmd.Parameters.Append cmd.CreateParameter("FIRST_LETTER", adVarchar, adParamInput, 2, strLetter)
cmd.execute
'return the recordset
GetSubscriberCountPerLetter = cmd.Parameters("SUBSCRIBER_COUNT")
'release cmd object from memory
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetSubscriberCountPerLetter", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetUrlFromUrlId function takes the url id and returns the url string.
Function GetUrlFromUrlId(intUrlId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_URL_FROM_ID"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("URL_ID", adInteger, adParamInput, , intUrlId)
cmd.Parameters.Append cmd.CreateParameter("URL_NAME", adVarchar, adParamOutput, 250)
cmd.execute
'return URL
GetUrlFromUrlId = cmd.Parameters("URL_NAME")
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("DeleteUrl", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'-----------------------------------------
'The GetURLidFromURL function takes the url and returns the related url id.
Function GetURLidFromURL(strURL)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_URL_ID_FROM_URL"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("URL_ID", adInteger, adParamOutput)
cmd.Parameters.Append cmd.CreateParameter("URL_NAME", adVarchar, adParamInput, 250, strURL)
cmd.execute
'return URL ID
GetURLidFromURL = cmd.Parameters("URL_ID")
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetURLidFromURL", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'The GetSelectedUrl function takes a URL id returns the the related URL (as a recordset).
Function GetSelectedUrl(intUrlId)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_SELECTED_URL"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("URL_ID", adInteger, adParamInput, , intUrlId)
Set GetSelectedUrl = cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetSelectedUrl", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'the UsesAltTemplate function takes the url's section id and returns (true) if url uses alt template or (false) if not.
Function UsesAltTemplate(intUrlId)
'On Error Resume Next
Dim rsUrl
'get the url
Set rsUrl = GetSelectedUrl(intUrlId)
'return URL
UsesAltTemplate = rsUrl("URL_USES_ALT_TEMPLATE")
'release the recordset
rsUrl.Close
Set rsUrl = Nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("UsesAltTemplate", err.number, err.description)
End If
On Error Goto 0
End Function
'the GetURLDynamicFormId function takes a url and returns the related draft dynamic form id
Function GetURLDynamicFormId(strCurrentURL)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_URL_DYNAMIC_FORM_ID"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("URL_DYNAMIC_FORM_ID", adInteger, adParamOutput)
cmd.Parameters.Append cmd.CreateParameter("URL", adVarchar, adParamInput, 250, strCurrentURL)
cmd.execute
GetURLDynamicFormId = cmd.Parameters("URL_DYNAMIC_FORM_ID")
set cmd = nothing
If err.number <> 0 Then
Call ReportError("GetURLDynamicFormId", err.number, err.description)
End If
On Error Goto 0
End Function
'The GetAllPostingTypeArrayString function returns a string containing (array) Posting Types
Function GetAllPostingTypeArrayString()
On Error Resume Next
'dim strDelimiter is defined in the common_utils.asp file
dim rsPostingTypes
dim strPostingTypesString
dim intPostingTypeId
'get the recordset of posting types into rsPostingTypes
Set rsPostingTypes = GetPostingTypes()
'set default value of strPostingTypesString variable (empty string)
strPostingTypesString = ""
'if the recordset is not empty then...
If Not rsPostingTypes.Eof Then
'loop through the rsPostingTypes recordset...
Do While Not rsPostingTypes.Eof
'if the current posting type is subscribeable then...
If CBool(rsPostingTypes("POSTING_TYPE_USER_CAN_SUBSCRIBE")) Then
'start building the array string
If strPostingTypesString = "" Then
strPostingTypesString = rsPostingTypes("POSTING_TYPE_ID")
Else
strPostingTypesString = strPostingTypesString & strDelimiter & rsPostingTypes("POSTING_TYPE_ID")
End If
End If
'go to the next record in the rsPostingTypes recordset
rsPostingTypes.MoveNext
Loop
End If
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetAllPostingTypeArrayString", err.number, err.description)
End If
'return checkboxes of posting types
GetAllPostingTypeArrayString = strPostingTypesString
On Error GoTo 0
End Function
'the ConvertDateCdnToUS function takes a date in a CDN format (dd/mm/yyyy) and returns it in an american format.
Function ConvertDateCdnToUS(cdnDate)
'ConvertDateCdnToUS = Mid(cdnDate, 4, 2) & "/" & Left(cdnDate, 2) & "/" & Right(cdnDate, 4)
'ConvertDateCdnToUS = cdnDate
'test:temp
ConvertDateCdnToUS = Right(cdnDate, 4) & "-" & Mid(cdnDate, 4, 2) & "-" & Left(cdnDate, 2)
End Function
'The ModifyDFSubscriber takes a subscriber's id, first name, last name, email adress and organization, and sets these values in the database
Sub ModifyDFSubscriber(intSubscriberId, strFirstName, strLastName, strEmail, strOrganization)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_SET_DF_SUBSCRIBER"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_ID", adInteger, adParamInput, , intSubscriberId)
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_FIRST_NAME", adVarchar, adParamInput, 150, strFirstName)
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_LAST_NAME", adVarchar, adParamInput, 150, strLastName)
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_EMAIL", adVarchar, adParamInput, 150, strEmail)
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_ORGANIZATION", adVarchar, adParamInput, 150, strOrganization)
cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("ModifyDFSubscriber", err.number, err.description)
End If
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Sub
Function AddDFSubscriber(strFirstName, strLastName, strEmail, strOrganization)
On Error Resume Next
dim cmd
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_INSERT_DF_SUBSCRIBER"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_ID", adInteger, adParamOutput)
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_FIRST_NAME", adVarchar, adParamInput, 150, strFirstName)
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_LAST_NAME", adVarchar, adParamInput, 150, strLastName)
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_EMAIL", adVarchar, adParamInput, 150, strEmail)
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_ORGANIZATION", adVarchar, adParamInput, 150, strOrganization)
cmd.execute
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("AddDFSubscriber", err.number, err.description)
End If
'return the language abbreviation
AddDFSubscriber = cmd.Parameters("SUBSCRIBER_ID")
'release cmd object from memory
set cmd = nothing
On Error Goto 0
End Function
'The WriteSubscriberCookies function takes a subscriber's first name, last name and email and writes them as cookies on the client machine.
Sub WriteSubscriberCookies(strFirstName, strLastName, strEmail, strOrganization)
On Error Resume Next
'write the cookies on the machine
Response.Cookies("GreenButton")("SessionId") = Session.SessionID
Response.Cookies("GreenButton")("SubscriberEmail") = strEmail
Response.Cookies("GreenButton")("SubscriberOrganization") = strOrganization
Response.Cookies("GreenButton")("SubscriberFirstName") = strFirstName
Response.Cookies("GreenButton")("SubscriberLastName") = strLastName
Response.Cookies("GreenButton").Expires = DateAdd("YYYY",5,Date)
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("WriteSubscriberCookies", err.number, err.description)
End If
On Error Goto 0
End Sub
'The WriteDynamicFormCookie function writes a cookie on the client machine.
Sub WriteDynamicFormCookie(intDynamicFormId)
On Error Resume Next
'write the cookies on the machine
Response.Cookies("GreenButton_DynamicForm_" & intDynamicFormId)("AnsweredForm") = "True"
Response.Cookies("GreenButton_DynamicForm_" & intDynamicFormId).Expires = DateAdd("YYYY",5,Date)
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("WriteDynamicFormCookie", err.number, err.description)
End If
On Error Goto 0
End Sub
'This function returns all the groups with checkboxes
Function GetDynamicFormGroupCheckboxes(intDynamicFormId, intGroupId)
On Error Resume Next
dim rsGetGroups
dim rsGetGroups2
dim rsGetGroups3
dim rsGetTop
dim strCheckBoxesOut
dim intChkCounter1
dim intChkCounter2
dim intSubscriberId
dim strChecked
dim strTopChecked
'if a dynamic form id was submitted then...
If intDynamicFormId <> "" Then
intChkCounter1 = 1
strCheckBoxesOut = ""
strTopChecked = GetDynamicFormGroup(intDynamicFormId, 1)
set rsGetGroups = GetGroups(1)
'get all groups checkbox
strCheckBoxesOut = "All Groups "& vbCRLF
'loop through sub checkboxes
Do While not rsGetGroups.EOF
intChkCounter2 = 0
strCheckBoxesOut = strCheckBoxesOut & " "&rsGetGroups("GROUP_NAME")&" "& vbCRLF
Set rsGetGroups2 = GetGroups(rsGetGroups("GROUP_ID"))
Do while not rsGetGroups2.EOF
intChkCounter2 = intChkCounter2 + 1
strCheckBoxesOut = strCheckBoxesOut & " "&rsGetGroups2("GROUP_NAME")&" "& vbCRLF
rsGetGroups2.MoveNext
loop
intChkCounter1 = intChkCounter1 +1
rsGetGroups.MoveNext
loop
GetDynamicFormGroupCheckboxes = strCheckBoxesOut
If err.number <> 0 Then
Call ReportError("GetGroupCheckboxes", err.number, err.description)
End If
'release objects
rsGetGroups.close
set rsGetGroups = nothing
rsGetGroups2.close
set rsGetGroups2 = nothing
'if a dynamic form id was not submitted then...
Else
intChkCounter1 = 1
strCheckBoxesOut = ""
set rsGetGroups = GetGroups(1)
strCheckBoxesOut = "All Groups "& vbCRLF
Do while not rsGetGroups.EOF
intChkCounter2 = 0
strCheckBoxesOut = strCheckBoxesOut & " "&rsGetGroups("GROUP_NAME")&" "& vbCRLF
set rsGetGroups2 = GetGroups(rsGetGroups("GROUP_ID"))
Do while not rsGetGroups2.EOF
intChkCounter2 = intChkCounter2 + 1
strCheckBoxesOut = strCheckBoxesOut & " "&rsGetGroups2("GROUP_NAME")&" "& vbCRLF
rsGetGroups2.MoveNext
loop
intChkCounter1 = intChkCounter1 +1
rsGetGroups.MoveNext
loop
GetDynamicFormGroupCheckboxes = strCheckBoxesOut
If err.number <> 0 Then
Call ReportError("GetAllCheckboxes", err.number, err.description)
End If
'release objects
rsGetGroups.close
set rsGetGroups = nothing
rsGetGroups2.close
set rsGetGroups2 = nothing
'end: if a dynamic form id was submitted then...
End If
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetDynamicFormGroupCheckboxes", err.number, err.description)
End If
On Error Goto 0
End Function
'This function determines the group id for a dynamic form.
Function GetDynamicFormGroup(intDynamicFormId, intGroupId)
On Error Resume Next
dim cmd
dim rsBelongsToo
dim strChecked
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_DYNAMIC_FORM_GROUP_STATUS"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("DYNAMIC_FORM_ID", adInteger, adParamInput, , intDynamicFormId)
cmd.Parameters.Append cmd.CreateParameter("GROUP_ID", adInteger, adParamInput, , intGroupId)
'return recordset of subscriber info
Set rsBelongsToo = cmd.execute
'Determine if the checkboxe should be checked
if rsBelongsToo.EOF then
strChecked = ""
else
strChecked = "checked"
end if
GetDynamicFormGroup = strChecked
'release cmd and recordeset objects from memory
rsBelongsToo.Close
set rsBelongsToo = nothing
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetDynamicFormGroup", err.number, err.description)
End If
On Error Goto 0
End Function
'This function takes the dynamic form id and returns the the group id for a dynamic form.
Function GetDynamicFormGroupId(intDynamicFormId)
On Error Resume Next
dim cmd
dim rsBelongsToo
dim strChecked
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_DYNAMIC_FORM_GROUP_ID"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("GROUP_ID", adInteger, adParamOutput)
cmd.Parameters.Append cmd.CreateParameter("DYNAMIC_FORM_ID", adInteger, adParamInput, , intDynamicFormId)
'execute the query
cmd.execute
GetDynamicFormGroupId = cmd.Parameters("GROUP_ID")
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetDynamicFormGroupId", err.number, err.description)
End If
On Error Goto 0
End Function
'the InsertGroupSubscriber procedure takes a subscriber id and a group id and insert a group subscriber record.
Sub InsertGroupSubscriber(intSubscriberId, intGroupId)
On Error Resume Next
dim cmd
dim rsBelongsToo
dim strChecked
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_INSERT_GROUP_SUBSCRIBER"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("GROUP_ID", adInteger, adParamInput, , intGroupId)
cmd.Parameters.Append cmd.CreateParameter("SUBSCRIBER_ID", adInteger, adParamInput, , intSubscriberId)
'execute the query
cmd.execute
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("InsertGroupSubscriber", err.number, err.description)
End If
On Error Goto 0
End Sub
'This function takes the dynamic form id and returns the the group id for a dynamic form.
Function GetGroupDynamicFormId(intGroupId)
On Error Resume Next
dim cmd
dim rsBelongsToo
dim strChecked
set cmd = Server.CreateObject("ADODB.Command")
set cmd.ActiveConnection = conn
cmd.CommandText = "SP_GET_GROUP_DYNAMIC_FORM_ID"
cmd.CommandType = adCmdStoredProc
cmd.Parameters.Append cmd.CreateParameter("DYNAMIC_FORM_ID", adInteger, adParamOutput)
cmd.Parameters.Append cmd.CreateParameter("GROUP_ID", adInteger, adParamInput, , intGroupId)
'execute the query
cmd.execute
GetGroupDynamicFormId = cmd.Parameters("DYNAMIC_FORM_ID")
set cmd = nothing
'if an error has occured report it
If err.number <> 0 Then
Call ReportError("GetGroupDynamicFormId", err.number, err.description)
End If
On Error Goto 0
End Function
%>
width=31 height=16 border=0>
