<% Session.Timeout = 90 Dim MessageError, trc, rs Call OpenDBConnections( trc ) Select Case CleanInput(Request.Form("SUBMIT")) Case "Go" Select Case CleanInput(Request.QueryString("Action")) Case "Search" Call HTMLHeader Call SubPageHeader("Education Categories") Call PageBody( "SearchResults", "", "" ) Case Else Call HTMLHeader Call SubPageHeader("Education Categories") Call PageBody( "ViewCategories", "", "" ) End Select Case Else Select Case CleanInput(Request.QueryString("Action")) Case "View" Call HTMLHeader Call SubPageHeader("") Call PageBody( "ViewArticle", CleanInput(Request.QueryString("ID")), "" ) Case "Expand" Session( "ECExpand" & Trim(CleanInput(Request.QueryString("ID"))) ) = "+" Call HTMLHeader Call SubPageHeader("Education Categories") Call PageBody( "ViewCategories", "", "" ) Case "Collapse" Session( "ECExpand" & Trim(CleanInput(Request.QueryString("ID"))) ) = "-" Call HTMLHeader Call SubPageHeader("Education Categories") Call PageBody( "ViewCategories", "", "" ) Case Else Call HTMLHeader Call SubPageHeader("Education Categories") Call PageBody( "ViewCategories", "", "" ) End Select End Select Sub HTMLHeader %> TeamRoper.com Education Categories <% End Sub Sub PageBody( Action, Parm1, Parm2 ) Dim cc1, cc2, cc3, cw1, cw2, cw3 Call ShowErrorMessage( MessageError ) Select Case Action Case "ViewArticle" cw1 = "0" : cw2 = "100%" : cw3 = "0" cc1 = "#FFFFFF" : cc2 = "#FFFFFF" : cc3 = "#FFFFFF" Case Else cw1 = "150" : cw2 = "550" : cw3 = "0" cc1 = "#FFFFFF" : cc2 = "#FFFFFF" : cc3 = "#FFFFFF" End Select %>
<% Select Case Action Case "ViewArticle" Case Else Call ITSearchBox Call WhiteSpacer(12) Call EDRecentArticlesHTML( trc, 3, 10 ) Call WhiteSpacer(12) Response.Write( GetAdHTML( trc, NextADIDToView( trc, 8 ) ) ) End Select %> <% Select Case Action Case "ViewArticle" Call EDViewArticle( trc, Parm1 ) Case "SearchResults" Call EDSearchResults( trc, CleanInput(Request.Form("ITSearchWords")) ) Call EDViewCategories( trc, 3 ) Case Else Call EDViewCategories( trc, 3 ) End Select %> <% Select Case Action Case Else End Select %>
     
<% End Sub %><% '-------------------------------------------------------------------- ' Microsoft ADO ' ' (c) 1996-1998 Microsoft Corporation. All Rights Reserved. ' ' ' ' ADO constants include file for VBScript ' '-------------------------------------------------------------------- '---- CursorTypeEnum Values ---- Const adOpenForwardOnly = 0 Const adOpenKeyset = 1 Const adOpenDynamic = 2 Const adOpenStatic = 3 '---- CursorOptionEnum Values ---- Const adHoldRecords = &H00000100 Const adMovePrevious = &H00000200 Const adAddNew = &H01000400 Const adDelete = &H01000800 Const adUpdate = &H01008000 Const adBookmark = &H00002000 Const adApproxPosition = &H00004000 Const adUpdateBatch = &H00010000 Const adResync = &H00020000 Const adNotify = &H00040000 Const adFind = &H00080000 '---- LockTypeEnum Values ---- Const adLockReadOnly = 1 Const adLockPessimistic = 2 Const adLockOptimistic = 3 Const adLockBatchOptimistic = 4 '---- ExecuteOptionEnum Values ---- Const adRunAsync = &H00000010 Const adAsyncExecute = &H00000010 Const adAsyncFetch = &H00000020 Const adAsyncFetchNonBlocking = &H00000040 Const adExecuteNoRecords = &H00000080 '---- ConnectOptionEnum Values ---- Const adAsyncConnect = &H00000010 '---- ObjectStateEnum Values ---- Const adStateClosed = &H00000000 Const adStateOpen = &H00000001 Const adStateConnecting = &H00000002 Const adStateExecuting = &H00000004 Const adStateFetching = &H00000008 '---- CursorLocationEnum Values ---- Const adUseServer = 2 Const adUseClient = 3 '---- DataTypeEnum Values ---- Const adEmpty = 0 Const adTinyInt = 16 Const adSmallInt = 2 Const adInteger = 3 Const adBigInt = 20 Const adUnsignedTinyInt = 17 Const adUnsignedSmallInt = 18 Const adUnsignedInt = 19 Const adUnsignedBigInt = 21 Const adSingle = 4 Const adDouble = 5 Const adCurrency = 6 Const adDecimal = 14 Const adNumeric = 131 Const adBoolean = 11 Const adError = 10 Const adUserDefined = 132 Const adVariant = 12 Const adIDispatch = 9 Const adIUnknown = 13 Const adGUID = 72 Const adDate = 7 Const adDBDate = 133 Const adDBTime = 134 Const adDBTimeStamp = 135 Const adBSTR = 8 Const adChar = 129 Const adVarChar = 200 Const adLongVarChar = 201 Const adWChar = 130 Const adVarWChar = 202 Const adLongVarWChar = 203 Const adBinary = 128 Const adVarBinary = 204 Const adLongVarBinary = 205 Const adChapter = 136 Const adFileTime = 64 Const adDBFileTime = 137 Const adPropVariant = 138 Const adVarNumeric = 139 '---- FieldAttributeEnum Values ---- Const adFldMayDefer = &H00000002 Const adFldUpdatable = &H00000004 Const adFldUnknownUpdatable = &H00000008 Const adFldFixed = &H00000010 Const adFldIsNullable = &H00000020 Const adFldMayBeNull = &H00000040 Const adFldLong = &H00000080 Const adFldRowID = &H00000100 Const adFldRowVersion = &H00000200 Const adFldCacheDeferred = &H00001000 Const adFldKeyColumn = &H00008000 '---- EditModeEnum Values ---- Const adEditNone = &H0000 Const adEditInProgress = &H0001 Const adEditAdd = &H0002 Const adEditDelete = &H0004 '---- RecordStatusEnum Values ---- Const adRecOK = &H0000000 Const adRecNew = &H0000001 Const adRecModified = &H0000002 Const adRecDeleted = &H0000004 Const adRecUnmodified = &H0000008 Const adRecInvalid = &H0000010 Const adRecMultipleChanges = &H0000040 Const adRecPendingChanges = &H0000080 Const adRecCanceled = &H0000100 Const adRecCantRelease = &H0000400 Const adRecConcurrencyViolation = &H0000800 Const adRecIntegrityViolation = &H0001000 Const adRecMaxChangesExceeded = &H0002000 Const adRecObjectOpen = &H0004000 Const adRecOutOfMemory = &H0008000 Const adRecPermissionDenied = &H0010000 Const adRecSchemaViolation = &H0020000 Const adRecDBDeleted = &H0040000 '---- GetRowsOptionEnum Values ---- Const adGetRowsRest = -1 '---- PositionEnum Values ---- Const adPosUnknown = -1 Const adPosBOF = -2 Const adPosEOF = -3 '---- enum Values ---- Const adBookmarkCurrent = 0 Const adBookmarkFirst = 1 Const adBookmarkLast = 2 '---- MarshalOptionsEnum Values ---- Const adMarshalAll = 0 Const adMarshalModifiedOnly = 1 '---- AffectEnum Values ---- Const adAffectCurrent = 1 Const adAffectGroup = 2 Const adAffectAll = 3 Const adAffectAllChapters = 4 '---- ResyncEnum Values ---- Const adResyncUnderlyingValues = 1 Const adResyncAllValues = 2 '---- CompareEnum Values ---- Const adCompareLessThan = 0 Const adCompareEqual = 1 Const adCompareGreaterThan = 2 Const adCompareNotEqual = 3 Const adCompareNotComparable = 4 '---- FilterGroupEnum Values ---- Const adFilterNone = 0 Const adFilterPendingRecords = 1 Const adFilterAffectedRecords = 2 Const adFilterFetchedRecords = 3 Const adFilterPredicate = 4 Const adFilterConflictingRecords = 5 '---- SearchDirectionEnum Values ---- Const adSearchForward = 1 Const adSearchBackward = -1 '---- PersistFormatEnum Values ---- Const adPersistADTG = 0 Const adPersistXML = 1 Const adPersistHTML = 2 '---- StringFormatEnum Values ---- Const adStringXML = 0 Const adStringHTML = 1 Const adClipString = 2 '---- ADCPROP_UPDATECRITERIA_ENUM Values ---- Const adCriteriaKey = 0 Const adCriteriaAllCols = 1 Const adCriteriaUpdCols = 2 Const adCriteriaTimeStamp = 3 '---- ADCPROP_ASYNCTHREADPRIORITY_ENUM Values ---- Const adPriorityLowest = 1 Const adPriorityBelowNormal = 2 Const adPriorityNormal = 3 Const adPriorityAboveNormal = 4 Const adPriorityHighest = 5 '---- ConnectPromptEnum Values ---- Const adPromptAlways = 1 Const adPromptComplete = 2 Const adPromptCompleteRequired = 3 Const adPromptNever = 4 '---- ConnectModeEnum Values ---- Const adModeUnknown = 0 Const adModeRead = 1 Const adModeWrite = 2 Const adModeReadWrite = 3 Const adModeShareDenyRead = 4 Const adModeShareDenyWrite = 8 Const adModeShareExclusive = &Hc Const adModeShareDenyNone = &H10 '---- IsolationLevelEnum Values ---- Const adXactUnspecified = &Hffffffff Const adXactChaos = &H00000010 Const adXactReadUncommitted = &H00000100 Const adXactBrowse = &H00000100 Const adXactCursorStability = &H00001000 Const adXactReadCommitted = &H00001000 Const adXactRepeatableRead = &H00010000 Const adXactSerializable = &H00100000 Const adXactIsolated = &H00100000 '---- XactAttributeEnum Values ---- Const adXactCommitRetaining = &H00020000 Const adXactAbortRetaining = &H00040000 '---- PropertyAttributesEnum Values ---- Const adPropNotSupported = &H0000 Const adPropRequired = &H0001 Const adPropOptional = &H0002 Const adPropRead = &H0200 Const adPropWrite = &H0400 '---- ErrorValueEnum Values ---- Const adErrInvalidArgument = &Hbb9 Const adErrNoCurrentRecord = &Hbcd Const adErrIllegalOperation = &Hc93 Const adErrInTransaction = &Hcae Const adErrFeatureNotAvailable = &Hcb3 Const adErrItemNotFound = &Hcc1 Const adErrObjectInCollection = &Hd27 Const adErrObjectNotSet = &Hd5c Const adErrDataConversion = &Hd5d Const adErrObjectClosed = &He78 Const adErrObjectOpen = &He79 Const adErrProviderNotFound = &He7a Const adErrBoundToCommand = &He7b Const adErrInvalidParamInfo = &He7c Const adErrInvalidConnection = &He7d Const adErrNotReentrant = &He7e Const adErrStillExecuting = &He7f Const adErrOperationCancelled = &He80 Const adErrStillConnecting = &He81 Const adErrNotExecuting = &He83 Const adErrUnsafeOperation = &He84 '---- ParameterAttributesEnum Values ---- Const adParamSigned = &H0010 Const adParamNullable = &H0040 Const adParamLong = &H0080 '---- ParameterDirectionEnum Values ---- Const adParamUnknown = &H0000 Const adParamInput = &H0001 Const adParamOutput = &H0002 Const adParamInputOutput = &H0003 Const adParamReturnValue = &H0004 '---- CommandTypeEnum Values ---- Const adCmdUnknown = &H0008 Const adCmdText = &H0001 Const adCmdTable = &H0002 Const adCmdStoredProc = &H0004 Const adCmdFile = &H0100 Const adCmdTableDirect = &H0200 '---- EventStatusEnum Values ---- Const adStatusOK = &H0000001 Const adStatusErrorsOccurred = &H0000002 Const adStatusCantDeny = &H0000003 Const adStatusCancel = &H0000004 Const adStatusUnwantedEvent = &H0000005 '---- EventReasonEnum Values ---- Const adRsnAddNew = 1 Const adRsnDelete = 2 Const adRsnUpdate = 3 Const adRsnUndoUpdate = 4 Const adRsnUndoAddNew = 5 Const adRsnUndoDelete = 6 Const adRsnRequery = 7 Const adRsnResynch = 8 Const adRsnClose = 9 Const adRsnMove = 10 Const adRsnFirstChange = 11 Const adRsnMoveFirst = 12 Const adRsnMoveNext = 13 Const adRsnMovePrevious = 14 Const adRsnMoveLast = 15 '---- SchemaEnum Values ---- Const adSchemaProviderSpecific = -1 Const adSchemaAsserts = 0 Const adSchemaCatalogs = 1 Const adSchemaCharacterSets = 2 Const adSchemaCollations = 3 Const adSchemaColumns = 4 Const adSchemaCheckConstraints = 5 Const adSchemaConstraintColumnUsage = 6 Const adSchemaConstraintTableUsage = 7 Const adSchemaKeyColumnUsage = 8 Const adSchemaReferentialContraints = 9 Const adSchemaTableConstraints = 10 Const adSchemaColumnsDomainUsage = 11 Const adSchemaIndexes = 12 Const adSchemaColumnPrivileges = 13 Const adSchemaTablePrivileges = 14 Const adSchemaUsagePrivileges = 15 Const adSchemaProcedures = 16 Const adSchemaSchemata = 17 Const adSchemaSQLLanguages = 18 Const adSchemaStatistics = 19 Const adSchemaTables = 20 Const adSchemaTranslations = 21 Const adSchemaProviderTypes = 22 Const adSchemaViews = 23 Const adSchemaViewColumnUsage = 24 Const adSchemaViewTableUsage = 25 Const adSchemaProcedureParameters = 26 Const adSchemaForeignKeys = 27 Const adSchemaPrimaryKeys = 28 Const adSchemaProcedureColumns = 29 Const adSchemaDBInfoKeywords = 30 Const adSchemaDBInfoLiterals = 31 Const adSchemaCubes = 32 Const adSchemaDimensions = 33 Const adSchemaHierarchies = 34 Const adSchemaLevels = 35 Const adSchemaMeasures = 36 Const adSchemaProperties = 37 Const adSchemaMembers = 38 '---- SeekEnum Values ---- Const adSeekFirstEQ = &H1 Const adSeekLastEQ = &H2 Const adSeekGE = &H4 Const adSeekGT = &H8 Const adSeekLE = &H10 Const adSeekLT = &H20 %> <% Sub HomePageHeader() ''' ' Session("T1") --> Session("T6") are the titles of the hyperlinks in the navigation bar. ' Session("U1") --> Session("U6") are the corresponding url's of the hyperlinks ' Session("HPHAdvertisementHTML") = HTML inserted in the advertising block. If Len(Session("T1")) = 0 Then Session("T1") = "Ropings" Session("U1") = "/Ropings/Default.asp" End If If Len(Session("T2")) = 0 Then Session("T2") = "Clinics" Session("U2") = "/Clinics/Default.asp" End If If Len(Session("T3")) = 0 Then Session("T3") = "Trading Arena" Session("U3") = "/Trading/SearchView.asp" End If If Len(Session("T4")) = 0 Then Session("T4") = "Shopping" Session("U4") = "http://www.nrsworld.com" End If If Len(Session("T5")) = 0 Then Session("T5") = "Discussion" Session("U5") = "/Discussion/CategoryView.asp" End If If Len(Session("T6")) = 0 Then Session("T6") = "Education" Session("U6") = "/Education/Default.asp" End If ' If Len(Session("T7")) = 0 Then ' Session("T7") = "View Ads" ' Session("U7") = "/Trading/SearchView.asp" ' End If %>
TeamRoper.com - A Community for Team Ropers
<% If MemberSignedIn( trc ) Then %>

Member Info

<% Else %>

Log-In

<% End If %>

Join TeamRoper.com

<%=GetAdHTML( trc, NextADIDToView( trc, 1 ) )%>
  Magazine      The Marketplace " class="LeftHyperlinks"><%=Session("T8")%>        " class="LeftHyperlinks"><%=Session("T1")%>        " class="LeftHyperlinks"><%=Session("T2")%>        " class="LeftHyperlinks"><%=Session("T3")%>        " target="_blank" class="LeftHyperlinks"><%=Session("T4")%>        " class="LeftHyperlinks"><%=Session("T5")%>        " class="LeftHyperlinks"><%=Session("T6")%>     
<% End Sub Sub SubPageHeader( PageTitleHTML ) ''' ' Session("T1") --> Session("T7") are the titles of the hyperlinks in the navigation bar. ' Session("U1") --> Session("U7") are the corresponding url's of the hyperlinks ' Session("SPHAdvertisementHTML") = HTML inserted in the advertising block. If Len(Session("T1")) = 0 Then Session("T1") = "Ropings" Session("U1") = "/Ropings/Default.asp" End If If Len(Session("T2")) = 0 Then Session("T2") = "Clinics" Session("U2") = "/Clinics/Default.asp" End If If Len(Session("T3")) = 0 Then Session("T3") = "Trading Arena" Session("U3") = "/Trading/SearchView.asp" End If If Len(Session("T4")) = 0 Then Session("T4") = "Shopping" Session("U4") = "http://www.nrsworld.com" End If If Len(Session("T5")) = 0 Then Session("T5") = "Discussion" Session("U5") = "/Discussion/CategoryView.asp" End If If Len(Session("T6")) = 0 Then Session("T6") = "Education" Session("U6") = "/Education/Default.asp" End If ' If Len(Session("T7")) = 0 Then ' Session("T7") = "View Ads" ' Session("U7") = "/Trading/SearchView.asp" ' End If %>
<% If Len(PageTitleHTML) > 0 Then %> <% End If %>
TeamRoper.com - A Community for Team Ropers
<% If MemberSignedIn( trc ) Then %>

Member Info

<% Else %>

Log-In

<% End If %>

Join TeamRoper.com

<%=GetAdHTML( trc, NextADIDToView( trc, 1 ) )%>
Magazine     The Marketplace      " class="LeftHyperlinks"><%=Session("T1")%>      " class="LeftHyperlinks"><%=Session("T2")%>      " class="LeftHyperlinks"><%=Session("T3")%>      " class="LeftHyperlinks" target="_blank"><%=Session("T4")%>       " class="LeftHyperlinks"><%=Session("T5")%>       " class="LeftHyperlinks"><%=Session("T6")%>    
<% If Instr(PageTitleHTML," 0 Then Response.Write(PageTitleHTML) Else %>

<%=PageTitleHTML%>

<% End If %>
<% End Sub Sub SiteManagerPageHeader( pagetitle ) ''' ' Session("T1") --> Session("T6") are the titles of the hyperlinks in the navigation bar. ' Session("U1") --> Session("U6") are the corresponding url's of the hyperlinks ' Session("SPHAdvertisementHTML") = HTML inserted in the advertising block. If Len(Session("SMT1")) = 0 Then Session("SMT1") = "Ropings" Session("SMU1") = "/Ropings/Default.asp" End If If Len(Session("T2")) = 0 Then Session("T2") = "Clinics" Session("U2") = "/Clinics/Default.asp" End If If Len(Session("SMT3")) = 0 Then Session("SMT3") = "Trading Arena" Session("SMU3") = "/Trading/SearchView.asp" End If If Len(Session("SMT4")) = 0 Then Session("SMT4") = "Shopping" Session("SMU4") = "http://www.nrsworld.com" End If If Len(Session("SMT5")) = 0 Then Session("SMT5") = "Discussion" Session("SMU5") = "/Discussion/CategoryView.asp" End If If Len(Session("SMT6")) = 0 Then Session("SMT6") = "Education" Session("SMU6") = "/Education/Default.asp" End If %>
TeamRoper.com - A Community for Team Ropers
<%=Mid( FormatDateTime(Now(),1), 1, InstrRev(FormatDateTime(Now(),1), ",")-1)%>
  
     Home      The Marketplace      " class="LeftHyperlinks"><%=Session("T1")%>      " class="LeftHyperlinks"><%=Session("T2")%>      " class="LeftHyperlinks"><%=Session("T3")%>      " class="LeftHyperlinks"><%=Session("T7")%>      " target="_blank" class="LeftHyperlinks"><%=Session("T4")%>       " class="LeftHyperlinks"><%=Session("T5")%>       " class="LeftHyperlinks"><%=Session("T6")%>    
<% End Sub Sub WhiteSpacer( pixels ) %>

<% End Sub %><% Sub MessageLog( ByRef trc, severity, message ) Dim sql ''' ' Severity levels are: I = info, W = warning, E = error, F = fatal ''' message = Left( message, 300 ) severity = UCase(Left(severity,1)) sql = "INSERT INTO MessageLog ( MLDate, MLIPAddress, MLUserID, MLPageName, MLMessage, MLSeverity ) " & _ "VALUES ( '" & Now() & "', '" & _ Request.ServerVariables("REMOTE_ADDR") & "', '" & _ Session("MemberID") & "', '" & _ Request.ServerVariables("SCRIPT_NAME") & "', '" & _ message & "', '" & _ severity & "')" trc.Execute(sql) End Sub Sub ShowErrorMessage( msg ) ''' ' Write out a standard HTML user error message table. Modifying this HTML will change the error messages ' for all pages. There are two message sources: (1) the parameter to this function and (2) the ' Session variable "MessageEror". MessageError is used when one page generates an error message that ' must be displayed on a page the user is redirected to. MessageError is cleared when this ' routine is run. Dim br If Len( msg ) > 0 OR Len( Session("MessageError") ) > 0 Then br = "" If Len( msg ) > 0 AND Len( Session("MessageError") ) > 0 Then br = "
" Response.Write("
") Response.Write("
" ) Response.Write("

") Response.Write( msg & br & Session("MessageError") ) Response.Write( "

" ) Session("MessageError") = Empty End If End Sub Sub AddMessageError( msgerr ) If Len(Trim(msgerr)) = 0 Then Exit Sub Session("MessageError") = Session("MessageError") & msgerr If Right(Trim(msgerr),4) <> "
" And Len(Session("MessageError")) > 0 Then _ Session("MessageError") = Session("MessageError") & "
" End Sub Sub ConfirmOrCancel( id, action, msg, width, style ) If Len(width) = 0 Then width = "width=""98%""" If Len(style) = 0 Then style = "style=""margin-left:10;""" %>
?Action=<%=action%>&ID=<%=id%>"> <%=style%> >

<%=msg%>
  

<% End Sub Sub GeneralMessage( msg, textcolor, bordercolor ) If Instr(textcolor,"#")=0 Then textcolor="#000000" If Instr(bordercolor,"#")=0 Then bordercolor="#CCCC66" %>

<%=msg%>

<% End Sub Function ConfirmMessage( msg, YesResponseURL, NoResponseURL ) Dim s s = msg & "
" & _ "[ YES ]" & _ "    " & _ "[ NO ]" ConfirmMessage = s End Function Sub WhiteSpacer( pixels ) %>

<% End Sub %><% Sub OpenDBConnections( ByRef trc ) Set trc = Server.CreateObject("ADODB.Connection") trc.Provider = "SQLOLEDB.1" trc.Properties("Network Library") = "dbmssocn" trc.Properties("Data Source") = "GSWS0001\PRWS" trc.Properties("Initial Catalog") = "TeamRoperCom" trc.Properties("User ID") = "TeamRoper" trc.Properties("Password") = "dally5456" trc.Open Session.Timeout = 90 End Sub %><% Function PageNumbers( totalpages, currentpage, subaction ) ''' ' displays a list of hyperlink page numbers ' totalpages = the total number of pages ' current page = the currently displayed page ' subaction = used to when multiple different areas of one page will use the page numbers routine. Dim s, i PageNumbers = Empty If totalpages < 2 Then Exit Function s = "

" & _ "" & _ "Page:" For i = 1 to totalpages s = s & "  " If i <> CInt(currentpage) Then s = s & "" & CStr(i) & "" Else s = s & CStr(i) End If Next s = s & "" PageNumbers = s End Function Function MoreNumbers( totalpages, currentpage, subaction, caption ) ''' ' displays a list of hyperlink more numbers... used inline when not referring to a page... ' totalpages = the total number of pages ' current page = the currently displayed page ' subaction = used to when multiple different areas of one page will use the page numbers routine. Dim s, i MoreNumbers = Empty If totalpages < 2 Then Exit Function s = caption For i = 1 to totalpages s = s & "  " If i <> CInt(currentpage) Then s = s & "" & CStr(i) & "" Else s = s & CStr(i) End If Next MoreNumbers = s End Function Function SimpleHTMLTable( contents, align, width, style ) If Len(align)=0 Then align="Left" If Len(width)=0 Then width="100%" s = "

" & _ "" & _ "" & _ "
" & _ contents & _ "
" SimpleHTMLTable = s End Function Function FormatPhone( phone ) If IsNull(phone) Or Len(phone) <> 10 Then FormatPhone = phone Else FormatPhone = "(" & Mid(phone,1,3) & ") " & Mid(phone,4,3) & "-" & Mid(phone,7) End If End Function Sub DPR( text ) Response.Write("

DEBUG:" & text & "

") End Sub Function EscapeApostrophe( text ) ''' ' changes a single aposrophe to a double so SQL Server won't error out Dim start, loc start = 1 Do While InStr( start, text, "'") > 0 loc = Instr( start, text, "'" ) text = Mid( text, 1, loc ) & "'" & Mid( text, loc + 1 ) start = loc + 2 Loop EscapeApostrophe = text End Function Function Capitolize(inval) ''' ' Make the first character capitolized ''' If Len(inval) > 1 Then Capitolize = UCase(Mid(inval, 1, 1)) & LCase(Mid(Inval,2)) Else Capitolize = UCase(inval) End If End Function Function IIF( ByVal test, ByVal trueval, ByVal falseval) If (test) Then IIF = trueval Else IIF = falseval End If End Function Function CRtoBR( text ) Dim x Do While Instr( text, vbCrLf ) <> 0 x = Instr( text, vbCrLf ) text = Mid(text, 1, x - 1) & "
" & Mid(text, x + 2 ) Loop CRtoBR = text End Function Function BRtoCR( text ) Dim x Do While Instr( text, "
" ) <> 0 x = Instr( text, "
" ) text = Mid(text, 1, x - 1) & vbCrLf & Mid(text, x + 4 ) Loop BRtoCR = text End Function Function BlankToNBSP( text ) Dim x Do While Instr( text, " " ) <> 0 x = Instr( text, " " ) text = Mid(text, 1, x - 1) & " " & Mid(text, x + 1 ) Loop BlankToNBSP = text End Function Function ValidID( id ) ''' ' ID is a numeric value used as an index into a table. This routine checks ' to see if its valid ''' ValidID = False If IsNull(id) Or Len(id)=0 Or IsEmpty(id) Then Exit Function id = DigitsOnly(id) If id=0 Or id="0" Then Exit Function ValidID = True End Function Function ValidEmail( email ) ValidEmail = True If Len(email) < 6 Or IsNull(email) Or IsEmpty(email) Then ValidEmail = False Exit Function End If If InStr(email,"@")=0 Then ValidEmail = False Exit Function End If If InStr(email,".")=0 Then ValidEmail = False Exit Function End If If InStr(email," ") <> 0 Then ValidEmail = False Exit Function End If If InStr(email, "'") <> 0 Then ValidEmail = False Exit Function End If End Function Function DigitsOnly(inval) ' this function strips everything from a string except ' the digits 0 through 9. it was originally created to ' strip the dashes out of a SSN Dim i , j , t If IsNull(inval) Then DigitsOnly = Null Exit Function End If If IsEmpty(inval) Or Len(inval)=0 Then DigitsOnly = Empty Exit Function End If For i = 1 To Len(inval) j = Asc(Mid(inval, i, 1)) If j < 59 And j > 47 Then t = t & Mid(inval, i, 1) Next DigitsOnly = t End Function Function NumericOnly(inval) ' this function strips everything from a string except ' the digits 0 through 9, period, + and - Dim i , j , t For i = 1 To Len(inval) j = Asc(Mid(inval, i, 1)) If ( j < 59 And j > 47 ) Or ( j=46 Or j=45 Or j=43 ) Then t = t & Mid(inval, i, 1) Next NumericOnly = t End Function Function ReplaceAll( ByVal inval, srch, repl ) Dim i, s i = 0 s = InStr( inval, srch ) Do While s <> 0 And i < 200 inval = Replace( inval, srch, repl ) s = InStr( inval, srch ) i = i + 1 Loop ReplaceAll = inval End Function Function WordCount( ByVal inval ) Dim a, s WordCount = 0 If IsNull(inval) Or Len(inval) = 0 Then Exit Function s = ReplaceAll( inval, " ", " " ) a = Split( inval, " " ) WordCount = UBound( a ) + 1 End Function Function SplitLongStrings( ByVal inval ) Dim a, s, maxlength, strlength, newstr, newval, cc SplitLongStrings = inval If IsNull(inval) Or Len(inval) = 0 Then Exit Function newval = "" a = Split( inval, " " ) For Each s In a maxlength = 10 strlength = Len(s) newstr = "" If strlength > (maxlength) Then cc=1 Do While cc < strlength newstr = newstr & Mid( s, cc, cc + maxlength ) & " " cc = cc + maxlength + 1 Loop s = newstr End If newval = newval + s + " " Next SplitLongStrings = newval End Function Function ContainsHTML( ByVal inval ) ''' ' Checks to see if there are html codes in the "inval" text. Note, ' check only for significant HTML such as table and font codes. Do not ' check for
''' ContainsHTML = False inval = LCase(inval) If Instr( inval, " 0 Or _ Instr( inval, " 0 Or _ Instr( inval, " 0 Or _ Instr( inval, " 0 Then ContainsHTML = True End If End Function Function GetBodyHTML( inval ) ''' ' extract and return the HTML between the and tags ''' Dim sl, bs, be, s slc = LCase(inval) s = inval bs = Instr( slc, " 0 Then be = Instr( bs + 1, slc, ">" ) If be > 0 Then s = Mid( s, be + 1 ) End If slc = LCase(s) bs = Instr( slc, " 0 Then be = Instr( bs + 1, slc, ">" ) If be > 0 Then s = Mid( s, 1, be - 1) End If GetBodyHTML = s End Function Function GetFirst( number, rtype ) Dim i(21) GetFirst = Empty If Len(number) = 0 Then Exit Function If CInt(number) > 20 And rtype="TEXT" Then Exit Function Select Case rtype Case "TEXT" i(1) = "first" : i(2) = "second" : i(3) = "third" i(4) = "fourth" : i(5) = "fifth" : i(6) = "sixth" i(7) = "seventh" : i(8) = "eighth" : i(9) = "ninth" i(10) = "tenth" : i(11) = "eleventh" : i(12) = "twelfth" i(13) = "thirteenth" : i(14) = "forteenth" : i(15) = "fifteenth" i(16) = "sixteenth" : i(17) = "seventeenth" : i(18) = "eighteenth" i(19) = "nineteenth" : i(20) = "twentyth" GetFirst = i(number) Case "NUMERIC" If CInt(number) > 3 Then GetFirst = Trim(CStr(number)) & "th" Else i(1) = "1st" : i(2) = "2nd" : i(3) = "3rd" GetFirst = i(number) End If Case Else If CInt(number) > 3 Then GetFirst = Trim(CStr(number)) & "th" Else i(1) = "1st" : i(2) = "2nd" : i(3) = "3rd" GetFirst = i(number) End If End Select End Function Function Pad( msg, fieldlen, padchar ) If Len(msg) < fieldlen Then Pad = msg & String( fieldlen - Len(msg) , padchar ) Else Pad = Mid(msg, 1, fieldlen ) End If End Function Function CharBetween( inval, char ) ''' ' The string passed (inval) has each character seaparated by "char" ' Example: inval="TEST", char="-", returns="T-E-S-T" ''' Dim s s = Empty For i = 1 to Len(inval) s = s & Mid( inval, i, 1 ) & char Next CharBetween = s End Function Function RemovePrefixZero( inval ) RemovePrefixZero = inval cnt = 0 inval = Trim(inval) If Len(inval) < 2 Then RemovePrefixZero = inval Exit Function End If Do While Mid( inval, 1, 1 ) = "0" And cnt < 100 And Len(inval) > 1 inval = Mid( inval, 2 ) cnt = cnt + 1 Loop RemovePrefixZero = inval End Function Function GetSearchWords( SearchTerm, Delim, ByRef WordArray, AndOr ) ''' ' When passed a search term, the words in the term are separated out ' and placed into the WordArray array. If there is an occurence of "and" ' or "or" then AndOr is set accordingly. If both And & Or exist then ' "or" is the default. WordArray is empty if SearchTerm has zero length. ' Tick marks "'" and percent signs "%" are removed to prevent SQL errors. ''' Dim st, orval, anval, wa, cnt, rma, rm If Len(Delim) = 0 Then Delim = " " st = Trim(LCase(SearchTerm)) st = Replace( st, "'", "" ) st = Replace( st, "%", "" ) If Len(st) = 0 Then GetSearchWords = 0 Exit Function End If Do While InStr( st, " ") <> 0 ''' remove all double blanks st = Replace( st, " ", " " ) Loop AndOr = "AND" ''' default to AND orval = InStr( st, " or " ) anval = Instr( st, " and " ) If anval > 0 Then AndOr = "AND" ''' check for "AND" first because if both AND and OR exist If orval > 0 Then AndOr = "OR " ''' then OR is the default ''' ' remove common words ''' rm = "and,or,it,we,us,they,them,the,me,my,am,is,are,do,did,could,was," & _ "were,be,would,shall,should,has,have,had,been,must,does" rma = Split( rm, "," ) For Each rm In rma st = Replace( st, " " & rm & " ", " " ) Next ''' ' split words into array ''' wa = Split( st, Delim ) If IsEmpty(wa) Then GetSearchWords = 0 WordArray = Empty Else GetSearchWords = UBound( wa ) - LBound( wa ) + 1 WordArray = wa End If End Function Function RandomNumber( numdigits ) Dim mx, lb RandomNumber = 0 If Len( numdigits ) = 0 Then Exit Function If numdigits = 0 Then Exit Function Randomize mx = String( numdigits, "9" ) If numdigits = 1 Then lb = "1" Else lb = "1" & String( numdigits - 1, "0" ) End If lb = CLng(lb) mx = CLng(mx) RandomNumber = Trim( CStr( CLng( ( mx - lb + 1 ) * Rnd() + lb ) )) End Function Function GetUniqueID( ByRef trc, prefix, numdigits ) ''' ' prefix = the alpha prefix for the ID... example: TR for trading arena ' numdigits = the number of digits in the random number appended to the ID ' ' The unique id is the prefix followed by the julian date followed by the ' hour followed by a random number. ''' Dim id, rs, icnt, ocnt, srtry icnt = 0 ocnt = 0 Do Do icnt = icnt + 1 id = UCase(Trim(prefix)) & CStr(DatePart("y",Date)) & CStr(DatePart("h",Now)) & RandomNumber( numdigits + ocnt ) Set rs = trc.Execute("SELECT UniqueID FROM UniqueID WHERE UniqueID = '" & id & "'" ) Loop Until rs.EOF or icnt > 100 ocnt = ocnt + 1 Loop Until rs.EOF or ocnt > 6 ''' ' calculate the number of retries... the number of times a random number had to be generated before it ' was unique in the database. srtry = CStr( ( 100 * ( ocnt - 1 ) ) + icnt ) If ocnt <= 6 And rs.EOF Then trc.Execute( "INSERT INTO UniqueID ( UniqueID, UniqueIDLastUsed, UniqueIDPrefix, UniqueIDRetries ) " & _ "VALUES ('" & id & "', '" & Now() & "','" & prefix & "'," & srtry & ")" ) GetUniqueID = id End If rs.Close End Function Sub MiniSort( ByRef A(), ubound, asc ) ''' ' Sorts the first 'unbound' number of elements in the array A(). If all elements of A() ' are numeric then a numeric sort is done. If a non-numeric element of A() is found ' the sort is done in alpha mode. If ubound is zero then all the elements ' of A() are sorted. The first element is A(1). If asc is true then the ' sort is ascending, otherwise its descending Dim ub, lb, nm, sw If IsNull( ubound ) Or IsEmpty( ubound ) Then ub = 0 Else ub = CLng( ubound ) End If If ub = 1 Then Exit Sub ' If ub = 0 Then ub = UCase( A ) lb = 1 nm = TRUE For i = lb to ub If Not IsNumeric( A(i) ) Then nm = FALSE Exit For End If Next sw = TRUE Do While sw sw = FALSE For i = lb to ub - 1 If nm Then If CLng(A(i)) > CLng(A(i+1)) Then If asc Then tmp = A(i) A(i) = A(i+1) A(i+1) = tmp sw = TRUE End If End If Else If CStr(A(i)) > CStr(A(i+1)) Then If asc Then tmp = A(i) A(i) = A(i+1) A(i+1) = tmp sw = TRUE End If End If End If Next Loop End Sub Function CleanInput(sInput) 'Create a regular expression object Dim regEx Set regEx = New RegExp 'The global property tells the RegExp engine to find ALL matching 'substrings, instead of just the first instance. We need this to be true. regEx.Global = true 'Our pattern tells us what to find in the string... In this case, we find 'anything that isn't a numerical character, or a lowercase or 'uppercase alphabetic character regEx.Pattern = "[^0-9a-zA-Z.?!-()$&/:+*-_,$&()#!?]" 'Use the replace function of RegExp to clean the username. The replace 'function takes the string to search (using the Pattern above as the 'search criteria), and the string to replace any found strings with. 'In this case, we want to replace our matches with nothing (''), 'as the matching characters will be the ones we don't want in our username. CleanInput = regEx.Replace(sInput, " ") End Function Function CleanEmail(sInput) Dim regExEmail Set regExEmail= New RegExp regExEmail.Pattern = "[^0-9a-zA-Z@.-_]" regExEmail.Global = True CleanEmail = regExEmail.Replace(sInput, "") End Function Function CleanURL(sInput) Dim regExEmail Set regExEmail= New RegExp regExEmail.Pattern = "[^0-9a-zA-Z.:/-_]" regExEmail.Global = True CleanURL = regExEmail.Replace(sInput, "") End Function Function CleanHTML(sInput) Dim regExEmail Set regExEmail= New RegExp regExEmail.Pattern = "[^0-9a-zA-Z.:/><-_,$&()#!?]" regExEmail.Global = True CleanHTML = regExEmail.Replace(sInput, " ") End Function Function CleanHTMLObject(sInput) Dim regExEmail Set regExEmail= New RegExp regExEmail.Pattern = "[^0-9a-zA-Z.:/><-_,$&()#!?'""-]" regExEmail.Global = True CleanHTMLObject = regExEmail.Replace(sInput, " ") End Function Function HTMLDecode(sText) Dim I If Len(sText) > 0 Then sText = Replace(sText, """, Chr(34)) sText = Replace(sText, "<" , Chr(60)) sText = Replace(sText, ">" , Chr(62)) sText = Replace(sText, "&" , Chr(38)) sText = Replace(sText, " ", Chr(32)) For I = 1 to 255 'sText = Replace(sText, "&#" & I & ";", Chr(I)) Next HTMLDecode = sText Else HTMLDecode = "" End If End Function %><% Sub TableListView( connection, sql, colcnt, columns, widths, idcol, idurl, actions, tableparms ) ''' ' connection is the adodb connection to the desired database ' sql is the sql used to extract the record(s) to be listed ' colcnt is the count of columns to be displayed ' columns is a comma separated list of database column names ' widths is the width (either in % or pixels) of each of the columns. comma separated ' idcol is the column containing the database record id (primary key) ' idurl is the url prefix which the record's hyperlink will use. this allows the user ' to click the record and be taken to the record editor. ' ' If a column name has the keyword "AS" in it then the prefix word is the filed name ' and the suffix word is the column (visible) name. Example: MyField AS MyColumnName ' MyFiled is the database field name and MyColumnName is the name displayed in the ' column. ' ' Please note if you use % in the column widths that you must leave 5% for the last ' column which is auto generated. ''' Dim colnames, fldnames, colwidths, i, tw, rs, pctflag, qs, aflag If Len(sql) = 0 Then Exit Sub fldnames = Split( columns, ",", colcnt ) colnames = Split( columns, ",", colcnt ) colwidths = Split( widths, ",", colcnt ) If Len( tableparms ) = 0 Then tableparms = "border=""0"" cellspacing=""0"" cellpadding=""1"" " aflag = True If Len(actions)=0 Then aflag = False ''' ' How is the query string on the supplied url (idurl) passed... If has a ? then append url ' info with & instead ''' If Instr(idurl,"?") > 0 Then qs = "&" Else qs = "?" End If For i = 0 to colcnt - 1 ''' ' calculate the table width ''' If Instr(colwidths(i), "%") <> 0 Then pctflag = True tw = "100%" Exit For Else tw = tw + CInt( colwidths(i) ) End If ''' ' extract and separate column and field names ''' j = Instr( LCase(colnames(i)), " as " ) If j <> 0 Then colnames(i) = Trim(Mid( colnames(i), j + 4 )) fldnames(i) = Trim(Mid( fldnames(i), 1, j - 1 )) End If Next If (Not pctflag) And aflag Then tw = tw + 80 Response.Write("
") Response.Write("" ) Response.Write("") For i = 0 to colcnt - 1 Response.Write("" & vbCrLf ) Next If aflag Then If pctflag Then Response.Write("") End If Response.Write("") Set rs = connection.Execute( sql ) If rs.EOF Then Response.Write("" & vbCrLf ) End If Do While Not rs.EOF Response.Write("") For i = 0 to colcnt - 1 Response.Write("" & vbCrLf ) Next ''' ' Now write out the rightmost column which contains the action hyperlinks. The "actions" ' parameter can contain the following letters: "E" for edit, "D" for delete, "U" for upload and ' "V" for view, "M" for email. ''' If aflag Then If pctflag Then Response.Write("") End If Response.Write("") rs.MoveNext Loop rs.Close Response.Write("
") Else Response.Write(""">") End If Response.Write("") Response.Write(colnames(i)) Response.Write("") Response.Write("") Response.Write("Action
" ) Response.Write("") Response.Write("No items found.") Response.Write("
") Else Response.Write(""">") End If Response.Write("") If IsNull(rs(fldnames(i))) Or IsEmpty(rs(fldnames(i))) Or Len(rs(fldnames(i)))=0 Then Response.Write(" ") Else Response.Write(rs(fldnames(i))) End If Response.Write("") If Instr( actions, "E" ) Then Response.Write("" ) Response.Write("Edit" ) Response.Write("   ") End If If Instr( actions, "D" ) Then Response.Write("" ) Response.Write("Del" ) Response.Write("   ") End If If Instr( actions, "U" ) Then Response.Write("" ) Response.Write("Upload" ) Response.Write("   ") End If If Instr( actions, "V" ) Then Response.Write("" ) Response.Write("View" ) Response.Write("   ") End If If Instr( actions, "M" ) Then Response.Write("" ) Response.Write("EMail" ) Response.Write("   ") End If If Instr( actions, "R" ) Then Response.Write("" ) Response.Write("Restore" ) Response.Write("   ") End If Response.Write("
") End Sub Sub RenumberTableColumn( ByRef connection, TableName, WhereClause, IDColumn, RenumberColumn ) ''' ' Renumbers a numeric column in a table. DO NOT USE THIS PROCEDURE ON "ID" COLUMNS OR ' LINKS TO OTHER TABLES WILL BE BROKEN. ' ' connection = adodb connection ' TableName = name of table to be renumbered ' RenumberColumn = column in 'TableName' to be renumbered ''' Dim rs, sql, cntr, scntr Set rs = Server.CreateObject("ADODB.Recordset") sql = "SELECT * FROM " & TableName & " " If Len(WhereClause) > 0 Then sql = sql & WhereClause sql = sql & " ORDER BY " & RenumberColumn & " ASC, " & IDColumn & " ASC " rs.Open sql, connection, AdOpenDynamic, AdLockOptimistic, AdCmdText cntr = 2 scntr = CStr( cntr ) Do While Not rs.EOF rs( RenumberColumn ) = scntr rs.Update rs.MoveNext cntr = cntr + 2 scntr = CStr( cntr ) Loop rs.Close End Sub Function TableGetValue( ByRef trc, tablename, idcolumn, idvalue, idnumeric, columnname ) Dim rs TableGetValue = Null If Len(idcolumn)=0 Or Len(idvalue)=0 Or Len(columnname)=0 Or Len(tablename)=0 Then Exit Function If idnumeric = True Then sql = "SELECT " & columnname & " FROM " & tablename & " WHERE " & idcolumn & " = " & idvalue Else sql = "SELECT " & columnname & " FROM " & tablename & " WHERE " & idcolumn & " = '" & idvalue & "'" End If Set rs = trc.Execute(sql) If rs.EOF Then Exit Function TableGetValue = rs(columnname) rs.Close End Function Function RecordDetail( ByRef trc, sql, style ) ''' ' lists out all the fields and values from the sql query ''' Dim s, fld s = "
" & _ "" Set rs = trc.Execute( sql ) If Not rs.EOF Then For Each fld In rs.Fields s = s & "" & _ "" & _ "" Next Else s = s & "" & _ "" & _ "" End If s = s & "
" & _ "

" & _ "" & _ fld.Name & "

" & _ "

" & _ "" & _ fld.Value & "

" & _ "

" & _ "" & _ "No records found.

" RecordDetail = s End Function %><% Function NextADIDToView( ByRef trc, locatn ) Dim rs, tmp NextAdToView = 1 If Len(locatn) = 0 Then Exit Function ''' ' Check to see if this location has any ads in it. If not, exit the subroutine or error will occur ''' Set rs = trc.Execute("SELECT TOP 1 ADID FROM AdViewer WHERE AdLocation=" & locatn & " AND AdStatus='NORMAL'") 'Set rs = trc.Execute("SELECT TOP 1 ADID FROM AdViewer WHERE AdLocation=" & locatn & " AND AdStatus='NORMAL' AND (LEN(AdImageURL) > 3)") If rs.EOF Then Exit Function ''' ' This routine calculates the PercentViewed, EqualViews and PercentToView. ' PercentViewed is the number of times the ad was viewed divided by the total ' number of times all ads in that location were viewed. This gives the percentage ' of views an ad has had relative to the other ads in its location group. ' EqualViews is the percentage which represents all ads in the group having an ' equal number of views. If there are two ads then EqualViews is 50, three ads ' is 33 and so forth. ' PercentToView is the percentage the ad should be viewed. The AdFrequency boost ' is factored in here. ''' trc.Execute( "UPDATE AdViewer " & _ "SET AdPercentViewed = 100 * (AdViewCount + AdBaseCount) / " & _ " (SELECT SUM(AdViewCount + AdBaseCount) FROM AdViewer " & _ " WHERE AdLocation =" & locatn & " AND AdStatus = 'NORMAL'), " & _ "AdPercentEqualViews = 100 / " & _ " (SELECT COUNT(*) FROM AdViewer " & _ " WHERE AdLocation =" & locatn & " AND AdStatus = 'NORMAL'), " & _ "AdPercentToView = AdPercentEqualViews * AdFrequency " & _ "WHERE AdLocation =" & locatn & " AND AdStatus = 'NORMAL' " ) ''' ' This routine normalizes AdPercentToView so the sum is 100% ''' tmp = CDbl(1.0) Set rs = trc.Execute( "SELECT SUM(AdPercentToView) AS SM FROM AdViewer " & _ "WHERE AdLocation =" & locatn & " AND AdStatus = 'NORMAL' " ) If Not rs.EOF Then If Not( IsNull(rs("SM")) Or IsEmpty(rs("SM")) ) Then If CDbl(rs("SM"))=0.0 Then tmp = CDbl( rs("SM") ) End If End If trc.Execute( "UPDATE AdViewer " & _ "SET AdPercentToView = 100.0000 * AdPercentToView / " & FormatNumber( tmp, 5,-1,0,0 ) & " " & _ "WHERE AdLocation =" & locatn & " AND AdStatus = 'NORMAL' " ) Set rs = trc.Execute( "SELECT ADID, (AdPercentToView - AdPercentViewed) AS pct FROM AdViewer " & _ "WHERE AdLocation = " & locatn & " AND ADStatus='NORMAL' ORDER BY NEWID() " ) 'added ORDER BY NEWID() If Not rs.EOF Then NextADIDToView = rs("ADID") rs.Close End Function Sub AdBalanceBaseCounts( ByRef trc, locatn ) ''' ' Equalizes AdBaseCount relative to AdViewCount so that all ads are equally likely to ' be viewed. This is done by finding the largest value for AdBaseCount + AdViewCount ' in the group of ads defined by "locatn". Then taking this largest value and multiplying ' by the frequency boost (AdFrequency). This new value less the current view count ' is the new value for AdBaseCount ''' Dim rs, mbc, maf, sql, minbc, tmp Set rs = trc.Execute( "SELECT MAX(AdBaseCount + AdViewCount) AS MBC, " & _ "MIN(AdFrequency),1 AS MAF FROM AdViewer " & _ "WHERE AdLocation = " & locatn & " AND AdStatus='NORMAL'" ) If rs.EOF Then Exit Sub mbc = rs("MBC") ''' maximum base count maf = rs("MAF") ''' minimum ad frequency rs.Close If IsNull(maf) Or IsEmpty(maf) Then maf = CSng( 1.0 ) Else maf = CSng(maf) End If If IsNull(mbc) Or IsEmpty(mbc) Then mbc = CLng( 1 ) Else mbc = CLng(mbc) If CLng(mbc) < 2 Then mbc = CLng(2) End If Set rs = Server.CreateObject("ADODB.RecordSet") sql = "SELECT AdBaseCount, AdFrequency, AdLocation, AdViewCount FROM AdViewer " & _ "WHERE AdLocation=" & locatn & " AND AdStatus='NORMAL'" rs.Open sql, trc, adOpenDynamic, adLockPessimistic, adCmdText minbc = CLng(0) Do While Not rs.EOF tmp = CLng(mbc - CLng(rs("AdViewCount"))) tmp = tmp * CLng( CSng(rs("AdFrequency")) - maf + 1.0 ) If minbc = 0 Or minbc > tmp Then minbc = tmp rs("AdBaseCount") = tmp rs.Update rs.MoveNext Loop rs.Close ''' ' now minimize the value of AdBaseCount by subtracting the smallest value ' from all the other AdBaseCount values in the location group. ''' trc.Execute( "UPDATE AdViewer SET AdBaseCount = AdBaseCount - " & minbc & " + 2 " & _ "WHERE AdLocation=" & locatn & " AND AdStatus='NORMAL'" ) End Sub Sub IncrementAdViewCount( ByRef trc, adid ) ''' ' Increments the ad view count. ''' If Len(adid) = 0 Then Exit Sub trc.Execute("UPDATE AdViewer SET AdViewCount = AdViewCount + 1 WHERE ADID = " & adid ) End Sub Function GetAdHTML( ByRef trc, adid ) ''' ' Returns the HTML for an advertisement. ''' Dim rs, s GetAdHTML = "" If Len(adid) = 0 Then Exit Function Set rs = trc.Execute("SELECT * FROM AdViewer WHERE ADID = " & adid & " AND ADStatus='NORMAL'" ) If rs.EOF Then Exit Function If (Len(rs("AdImageURL")) = 0 And Len(rs("AdHTMLText")) = 0) Or _ ( IsNull(rs("AdImageURL")) AND IsNull(rs("AdHTMLText")) ) Then Exit Function ''' ' If there is an image for this ad, then use the image instead of the HTML text ''' If Len(Trim(rs("AdImageURL"))) > 0 Then s = "" & _ "" & _ "" Else s = "
" & _ "" & _ "" & _ "
" & _ rs("AdHTMLText") & _ "
" End If rs.Close GetAdHTML = s Call IncrementAdViewCount( trc, adid ) End Function Sub AdShowLocationsHTML( ByRef trc ) sql = "SELECT ADLID, ADLocationCode AS LocationCode, ADLocationDesc AS Location, ADLHeight AS Height, " & _ "ADLWidth AS Width FROM AdLocations ORDER BY ADLocationCode ASC" Call TableListView( trc, sql, 4, "LocationCode,Location,Height,Width", _ "80,200,80,80", "ADLID", "", "", "style=""margin-top:10;""" ) End Sub %><% Sub EDViewArticle( ByRef trc, eaid ) Dim rs If Not ValidID( eaid ) Then Call EDNoArticle Exit Sub End If Set rs = trc.Execute("SELECT * FROM EdArticles WHERE EAID = " & CStr(eaid) ) If rs.EOF Then Call EDNoArticle Exit Sub End If If Not EdAllowArticle( trc, eaid, Session("MemberID") ) Then Call EdNoArticle Exit Sub End If %>
<% If Len(rs("EATitle")) > 0 Then %> <% End If %>

<%=rs("EATitle")%>
<% If Len(rs("EAAuthor")) > 0 Then %>
By <%=rs("EAAuthor")%> <% End If %>

<% If ContainsHTML( rs("EABodyText") ) Then Response.Write( rs("EABodyText") ) Else %>

<%=rs("EABodyText")%>

<% End If %>
<% If Len(rs("EAWebPage")) > 0 And (Not IsNull(rs("EAWebPage"))) Then %>

"> Click here for more information.

<% End If %>

Last Updated: <%=FormatDateTime( rs("EALastUpdated"), 2 )%>
Published: <%=FormatDateTime( rs("EAPublishDate"), 2 )%>

<% End Sub Sub EDViewCategories( ByRef trc, aplid ) %>

Table of contents:
(click on the + to view topic contents) <% Response.Write( EDShowCategoryHTML( trc, 0, aplid ) ) %>

 
<% End Sub Sub EDNoArticle %>
 

The education article you requested is not available at this time.
We apologize for this inconvenience.

 
<% End Sub Function EDShowCategoryHTML( ByRef trc, ParentECID, ECAPLID ) Dim rs, xpnd, levl, marg, s, sql, pgname EDShowCategoryHTML = Empty If Not ( ValidID( ParentECID ) OR ParentECID=0 ) Then Exit Function sql = "SELECT * FROM EdCategories " & _ "WHERE ECParentECID = " & ParentECID & " AND " & _ " ECStatus = 'NORMAL' AND " & _ " ECAPLID = " & ECAPLID & " " & _ "ORDER BY ECDisplayOrder ASC " Set rs = trc.Execute( sql ) Do While Not rs.EOF ''' ' The session variable Session(ECExpandxxxx) contains either a "+" or a "-" if the category ' is to be expanded. Expanded means the sub categories and sub articles are to be shown. ' "xxxx" in the Session(ECExpandxxxx) above is the ECID: primary key of the EdCategories table. ''' xpnd = Session( "ECExpand" & Trim(CStr(rs("ECID"))) ) levl = EDGetCategoryLevel( trc, rs("ECID") ) ' category level is used to determine paragraph indentation marg = ( CInt(levl) + 1 ) * 15 pgname = Request.ServerVariables("SCRIPT_NAME") If xpnd = "-" Then ''' ' This category is not expanded so simply return the HTML ''' s = s & "

" & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf & _ "" & _ "" & _ " " & vbCrLf & _ "" & vbCrLf & _ rs("ECDisplayName") & vbCrLf & _ "

" & vbCrLf Session( "ECExpand" & Trim(CStr(rs("ECID"))) ) = "-" End If If xpnd = "+" Or Len(xpnd) = 0 Or IsNull(xpnd) Then s = s & "

" & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf & _ "" & _ "" & _ " " & vbCrLf & _ "" & vbCrLf & _ rs("ECDisplayName") & vbCrLf & _ "

" & vbCrLf Session( "ECExpand" & Trim(CStr(rs("ECID"))) ) = "+" ''' ' after displaying all categories, display articles within this category ''' s = s & EDShowArticlesHTML( trc, rs("ECID") ) ''' ' recursive call to this routine to show the child categories of this category ''' s = s & EDShowCategoryHTML( trc, rs("ECID"), ECAPLID ) End If rs.MoveNext Loop rs.Close EDShowCategoryHTML = s End Function Function EDShowArticlesHTML( ByRef trc, ecid ) ''' ' This routine extracts the education articles under a given category and returns ' formatted HTML titles (and authors) of each article. ''' Dim rs, s, levl, marg s = "" EDShowArticlesHTML = Empty If Not ValidID( ecid ) Then Exit Function levl = EDGetCategoryLevel( trc, ecid ) ' category level is used to determine paragraph indentation marg = (( CInt(levl) + 2 ) * 15) + 7 ' article margin ' "" & vbCrLf & _ Set rs = trc.Execute("SELECT EAID, EATitle, EAAuthor FROM EdArticles WHERE EAECID = " & ecid & " ORDER BY EAID DESC") Do While Not rs.EOF If EDAllowArticle( trc, rs("EAID"), Session("MemberID") ) Then ''' ' Show article only if user has permission ''' s = s & "

" & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf & _ "" & rs("EATitle") & " " If Len(rs("EAAuthor")) > 0 And Not IsNull(rs("EAAuthor")) Then s = s & "by " & rs("EAAuthor") s = s & "

" & vbCrLf End If rs.MoveNext Loop rs.Close If s = "
    " Then s = "" Else s = s & "
" End If EDShowArticlesHTML = s End Function Function EDGetCategoryLevel( ByRef trc, ecid ) ''' ' This routine returns a sublevel number of the category. Top level categories have a parentECID ' of zero. Example: ' This is my top level category. ( Level=0, ECID=11, ParentECID=0 ) ' This is sub level one category. ( Level=1, ECID=15, ParentECID=11 ) ' This is sub level two category. ( Level=2, ECID=9, ParentECID=15 ) ''' Dim pecid, rs, gcl gcl = 0 EDGetCategoryLevel = gcl If Not ValidID(ecid) Then Exit Function Set rs = trc.Execute("SELECT ECParentECID FROM EdCategories WHERE ECID = " & ecid ) If Not rs.EOF Then pecid = rs("ECParentECID") Else pecid = 0 End If Do While CLng(pecid) <> 0 And CInt(gcl) < 10 rs.Close gcl = gcl + 1 EDGetCategoryLevel = gcl If IsEmpty( pecid ) Or IsNull( pecid ) Or Len( pecid ) = 0 Then Exit Function Set rs = trc.Execute("SELECT ECParentECID FROM EdCategories WHERE ECID = " & pecid ) If Not rs.EOF Then pecid = rs("ECParentECID") Else pecid = 0 End If Loop rs.Close End Function Sub EDSearchResults( ByRef trc, sw ) Dim sql, wcnt, words, i wcnt = GetSearchWords( sw, " ", words, andor ) If IsEmpty(wcnt) Or IsNull(wcnt) Or wcnt = 0 Then sql = "SELECT TOP 50 * FROM EdARticles ORDER BY EALastUpdated DESC" Else sql = "SELECT * FROM EdArticles WHERE " For i = 0 To wcnt - 1 sql = sql & "( LOWER(EAKeywords) LIKE '%" & words(i) & "%' OR " & _ " LOWER(EATitle) LIKE '%" & words(i) & "%') " & andor & " " Next sql = Mid(sql, 1, Len(sql)-4) sql = sql & " ORDER BY EALastUpdated DESC " End If Call TableListView( trc, _ sql, _ 2, _ "EATitle AS Title,EAAuthor AS Author", _ "300,100", _ "EAID", _ "/Education/Default.asp", _ "V", _ "border=""0"" cellspacing=""0"" cellpadding=""1"" style=""margin-left:10;""" ) End Sub Function EDAllowArticle( ByRef trc, eaid, mmid ) ''' ' Based on the logged-in member id (mmid) determine if the article is visible to the ' user or not. Articles set to a hidden status are not visible to general users, only ' to the creator or administrator. ''' Dim rs, pm EDAllowArticle = False If Not ValidID( eaid ) Then Exit Function Set rs = trc.Execute("SELECT EAStatus, TOS FROM EdArticles WHERE EAID = " & eaid ) If rs.EOF Then rs.Close Exit Function End If Select Case rs("EAStatus") Case "HIDDEN" pm = GetPermission( trc, mmid, "MPEducationArticles" ) If pm = "W" Or pm="*" Or pm="C" Then EDAllowArticle = True End If Case Else If rs("TOS") = "P" Then ''' ' article has passed the TOS scanner so allow it to be viewed. ''' EDAllowArticle = True End If End Select rs.Close End Function %><% Function GetMemberName( ByRef trc, mmid ) ''' ' Returns a formatted member name. ''' Dim rs GetMemberName = Empty On Error Resume Next If IsNull(mmid) Or IsEmpty(mmid) Or Len(mmid) = 0 Then Exit Function Set rs = trc.Execute("SELECT MLastName, MFirstName FROM Members WHERE MID = " & mmid ) If Not rs.EOF Then GetMemberName = UCase( Mid(rs("MFirstName"),1,1) ) & LCase( Mid(rs("MFirstName"),2) ) & " " & _ UCase( Mid(rs("MLastName"),1,1) ) & LCase( Mid(rs("MLastName"),2) ) End If rs.Close End Function Function GetMemberEmail( ByRef trc, mmid ) Dim rs GetMemberEmail = Empty On Error Resume Next If IsNull(mmid) Or IsEmpty(mmid) Or Len(mmid) = 0 Then Exit Function Set rs = trc.Execute("SELECT MEmail FROM Members WHERE MID = " & mmid ) If Not rs.EOF Then GetMemberEmail = rs("MEmail") End If rs.Close End Function Function GetMemberPhone( ByRef trc, mmid ) Dim rs GetMemberPhone = Empty On Error Resume Next If IsNull(mmid) Or IsEmpty(mmid) Or Len(mmid) = 0 Then Exit Function Set rs = trc.Execute("SELECT MPhone1 FROM Members WHERE MID = " & mmid ) If Not rs.EOF Then GetMemberPhone = rs("MPhone1") End If rs.Close End Function Function GetMemberID( ByRef trc, memail ) GetMemberID = Empty Set rs = trc.Execute("SELECT MID FROM Members WHERE LOWER(MEMail) = '" & LCase(Trim(memail)) & "'") If Not rs.EOF Then GetMemberID = rs("MID") rs.Close End Function Sub GetMemberInfo( ByRef trc, ByRef fields, ByRef values ) ''' ' Searches the Members database for a specific member ID ( values(0) ) and ' returns the fields specified in the "fields" array passed to this routine ' Example: ' If fields(1) = MLastName Then values(1) will contain the last name. ' Upon entry, fields(0) should be "MID" and values(0) should have the numeric ' member ID to search for. ' If the search for the member fails for any reason then values(0) will ' be null. ''' Dim i, rs If Len(values(0)) = 0 Or IsNull(values(0)) Then values(0) = Null Exit Sub End If Set rs = trc.Execute( "SELECT * FROM Members WHERE MID = " & values(0) ) If Not rs.EOF Then For i = 1 to UBound(fields) If Len(fields(i)) > 1 Then values(i) = rs( fields(i) ) Else Exit For End If Next Else values(0) = Null End If rs.Close End Sub Function GetPermission( ByRef trc, mmid, permission ) Dim rs ''' ' Returns the permission level for a specific area of the site. "permission" is a column ' name in the MemberPermissions table which contains the permission value for the user(mid). ' If NULL is returned then the member was not found or an error occured. Otherwise the ' permission value will be returned. ' There are two types of permissions... "Yes/No" and "Write/Create/Read/None" ''' GetPermission = "N" 'On Error Resume Next If Not ValidMember( trc, mmid ) Then Exit Function Set rs = trc.Execute("SELECT * FROM MemberPermissions WHERE MPMID = " & mmid ) If rs.EOF Then Call MessageLog( trc, "E", "User with MemberID= " & mmid & " was not found in the MemberPermissions table." ) Call MessageLog( trc, "I", "Setting user permissions to default.") rs.Close ''' ' Close the recordset. Set permissions for new visitor and try again. ''' Call SetMemberPermissions( trc, mmid, "DEFAULT", FALSE ) Set rs = trc.Execute("SELECT * FROM MemberPermissions WHERE MPMID = " & mmid ) If rs.EOF Then Call MessageLog( trc, "E", "Failed to set user permissions." ) Exit Function End If Else If rs("MPMemberType") = "A" Then GetPermission="*" Else GetPermission = rs(permission) End If End If rs.Close On Error Goto 0 End Function Function SetPermission( ByRef trc, mid, permission, value ) Dim rs On Error Resume Next value = UCase(Trim(value)) If Not ValidMember( trc, mid ) Then Exit Function If Len(value) <> 1 Then Exit Function If Instr( "WCRDNY", value ) = 0 Then Exit Function trc.Execute("UPDATE MemberPermissions SET " & permission & "='" & value & "' WHERE MPMID=" & mid ) On Error Goto 0 End Function Sub SetMemberPermissions( ByRef trc, mmid, pgroup, force ) ''' ' Search the MemberPermissions for the MPGroupID=pgroup. Copy that record's contents ' into the permissions record for the user=mid. If the user exists and is not "New" ' then "force" must be true to force the permissions change. This will overwrite the ' existing permissions with the permissions of the group. ''' Dim rsg, rsm, overwrite If Len(mmid)=0 Or IsNull(mmid) Then Exit Sub If force <> TRUE Or IsNull(force) Then force = FALSE If Len(pgroup)=0 Or IsNull(pgroup) Then pgroup = "DEFAULT" ''' ' get the permissions of the specified group ''' Set rsg = trc.Execute("SELECT * FROM MemberPermissions WHERE MPGroupID='" & pgroup & "'") If rsg.EOF Then Set rsg = trc.Execute("SELECT * FROM MemberPermissions WHERE MPGroupID='DEFAULT'") If rsg.EOF Then Exit Sub End If ''' ' Find the permissions record of the specified user. If record doesn't exist, one is ' created and the permissions from the group=pgroup are copied into the new record. If ' the record exists then "force" must be True before the record will be overwritten. ''' Set rsm = trc.Execute("SELECT * FROM MemberPermissions WHERE MPMID=" & mmid ) If rsm.EOF Then rsm.Close Set rsm = Server.CreateObject("ADODB.Recordset") rsm.Open "MemberPermissions", trc, adOpenDynamic, adLockOptimistic, adCmdTable rsm.AddNew overwrite = True Else If force Then overwrite = True Else overwrite = False End If End If If overwrite Then rsm("MPGroupID") = "USER" rsm("MPMID") = mmid rsm("MPMemberType") = rsg("MPMemberType") rsm("MPAllowLogin") = rsg("MPAllowLogin") rsm("MPEducationArticles") = rsg("MPEducationArticles") rsm("MPAllowUploads") = rsg("MPAllowUploads") rsm("MPAdvertisements") = rsg("MPAdvertisements") rsm("MPSiteManager") = rsg("MPSiteManager") rsm("MPDiscussion") = rsg("MPDiscussion") rsm("MPEvents") = rsg("MPEvents") rsm("MPTrading") = rsg("MPTrading") rsm("MPContests") = rsg("MPContests") rsm("MPAnyPage") = rsg("MPAnyPage") rsm("MPAPLocations") = rsg("MPAPLocations") rsm("MPOrganizations") = rsg("MPOrganizations") rsm("MPPhotoGallery") = rsg("MPPhotoGallery") rsm("MPClinics") = "C" rsm("MPRopings") = "C" rsm.Update End If rsm.Close rsg.Close End Sub Function MemberSignIn( ByRef trc, memail, mpassword ) Dim addr MemberSignIn = False memail = LCase(Trim(memail)) mpassword = LCase(Trim(mpassword)) Session("MemberID") = ValidSignIn( trc, memail, mpassword ) Select Case CLng(Session("MemberID")) Case -1 Call AddMessageError("Please enter a valid email address and password.") Session("MemberID") = Empty Case -2 Call AddMessageError("The email address and/or password you entered is not valid. If you are not a member you may join TeamRoper.com " & _ "by clicking here. If you've forgotten your password, " & _ "click here." ) Session("MemberID") = Empty Case -3 Call AddMessageError("The email address and/or password you entered is not valid. If you are not a member you may join TeamRoper.com " & _ "by clicking here. If you've forgotten your password, " & _ "click here." ) Session("MemberID") = Empty Case -4 Call AddMessageError("Your membership record is incomplete or has some problems. " & _ "Please click here to become a member." ) Session("MemberID") = Empty Case Else MemberSignIn = True End Select If Len(Session("MemberID"))=0 Then Exit Function ''' ' Now update the member record indicating the last sign-in date and IP address ''' addr = Request.ServerVariables("REMOTE_ADDR") & ":" & Request.ServerVariables("REMOTE_HOST") & ":" & Request.ServerVariables("REMOTE_USER") addr = Mid(addr, 1, 299) trc.Execute( "UPDATE Members SET MLastSignIn = '" & Now() & "', " & _ "MLastIPAddress='" & addr & "' " & _ "WHERE MID = " & Session("MemberID") ) If ContestEntry( trc, Session("MemberID"), 1, "RopeGiveAway" ) Then _ Call AddMembershipMessage("You've been entered to win a rope!") End Function Function ValidSignIn( ByRef trc, memail, mpassword ) '''' ' Check to see if the supplied email and password match that in the ' member table. Returns codes which explain why sign-in is failing ' -1 = Invalid Email address ' -2 = Membership not found ' -3 = Password does not match ' -4 = Membership record is invalid '''' Dim rs ValidSignIn = CLng(-1) If Not ValidEmail( memail ) Then ValidSignIn = CLng(-1) Exit Function End If Set rs = trc.Execute("SELECT MID, MPassword FROM Members WHERE LOWER(MEMail) = '" & LCase(memail) & "'") If rs.EOF Then ValidSignIn = CLng(-2) rs.Close Exit Function End If If LCase(rs("MPassword")) <> LCase(mpassword) Then ValidSignIn = CLng(-3) rs.Close Exit Function End If If IsNull( rs("MID") ) Then ValidSignIn = CLng(-4) rs.Close Exit Function End If ValidSignIn = CLng(rs("MID")) rs.Close End Function Function MemberSignOut Session("MemberID") = Empty Call MembershipClearSessVars End Function Function MemberSignedIn( ByRef trc ) ''' ' returns true if MID is signed in, False otherwise If ValidMember( trc, Session("MemberID") ) Then MemberSignedIn = True Else MemberSignedIn = False End If End Function Function GetMemberCookie( ByRef trc ) Dim mid GetMemberCookie = Empty mid = CleanInput(Request.Cookies( "ATFEEABMRRAORPYE2RCM")("MID")) If ValidMember( trc, mid ) Then GetMemberCookie = mid Else GetMemberCookie = Empty End If End Function Sub SetMemberCookie( ByRef trc, mid ) If ValidMember( trc, mid ) Then Response.Cookies( "ATFEEABMRRAORPYE2RCM" ).Secure = FALSE Response.Cookies( "ATFEEABMRRAORPYE2RCM").Expires = DateAdd("yyyy", 1, Now()) Response.Cookies( "ATFEEABMRRAORPYE2RCM")("MID") = Trim(CStr(mid)) End If End Sub Sub ClearMemberCookie ''' ' This routine is run if the customer deletes his membership. After deleting ' the membership in the database, the cookie must also be cleared otherwise ' the deleted email address will continue. ''' Response.Cookies( "ATFEEABMRRAORPYE2RCM").Secure = FALSE Response.Cookies( "ATFEEABMRRAORPYE2RCM").Expires = DateAdd("d", -1, Now()) Response.Cookies( "ATFEEABMRRAORPYE2RCM")("MID") = Empty End Sub Sub SetAutoSignIn( ByRef trc, mid, setauto ) If Not ValidMember( trc, mid ) Then Exit Sub If UCase(Trim(setauto)) = "Y" Then trc.Execute("UPDATE Members SET MAutoSignIn='Y' WHERE MID = " & mid ) Call SetMemberCookie( trc, mid ) Else trc.Execute("UPDATE Members SET MAutoSignIn='N' WHERE MID = " & mid ) Call ClearMemberCookie End If End Sub Function AutoSignIn( ByRef trc, mid ) ''' ' This routine is passed the MID from GetMemberCookie Dim mm, rs, mp AutoSignIn = False If IsEmpty(mid) Or IsNull(mid) Or Len(mid) = 0 Then Exit Function If Len(Session("MemberID")) > 0 Then Exit Function If ValidMember( trc, mid) Then Set rs = trc.Execute("SELECT MEMail, MPassword, MAutoSignIn FROM Members WHERE MID = " & mid ) If Not rs.EOF Then If rs("MAutoSignIn") = "Y" Then ''' ' did the user request automatic sign in? If he did then sign in, otherwise, don't ''' mm = rs("MEMail") mp = rs("MPassword") rs.Close If MemberSignIn( trc, mm, mp ) Then AutoSignIn = True Else rs.Close trc.Execute("UPDATE Members SET MAutoSignIn='N' WHERE MID = " & mid ) Call ClearMemberCookie End If End If End If End Function Function ValidMember( ByRef trc, mmid ) ''' ' A valid member is one who has an entry in the Members table with ' a member status (MStatus) of "A" and who's member permissions ' allow login to the site. ''' Dim rsm, rsp ValidMember = False On Error Resume Next If IsNull(mmid) Or IsEmpty(mmid) Or Len(mmid) = 0 Then Exit Function Set rsm = trc.Execute("SELECT * FROM Members WHERE MID = " & mmid ) Set rsp = trc.Execute("SELECT * FROM MemberPermissions WHERE MPMID = " & mmid ) If rsp.EOF And NOT rsm.EOF Then ''' ' Member has not signed into the new TeamRoper and doesn't have a permissions ' record so set one up. ''' rsp.Close Call SetMemberPermissions( trc, mmid, "DEFAULT", FALSE ) Set rsp = trc.Execute("SELECT * FROM MemberPermissions WHERE MPMID = " & mmid ) End If If rsp.EOF Or rsm.EOF Then rsp.Close rsm.Close Exit Function End If If rsm("MStatus")<>"A" Then rsp.Close rsm.Close Exit Function End If If rsp("MPAllowLogin") = "N" Then rsp.Close rsm.Close Exit Function End If ValidMember = True rsp.Close rsm.Close On Error Goto 0 End Function Function AllowChanges( ByRef trc, cmid, lmid, permission ) ''' ' Returns true or false if the member is allowed to make changes. ' trc = the database connection object ' cmid = the member id of the member who created the record (i.e. the owner of the record). ' lmid = the member id of the currently logged in member ' permission = the permission object ( a field in the MemberPermissions table ) being querried. ''' ' To obtain permission to allow changes to a changeable object ( an education article or a trading arena ad.... ) ' the following must happen: ' (1) The logged in member (lmid) has administrator rights (p="*") ' (2) The logged in member has universal write priveleges to the specified permission (p="W") ' (3) The logged in member is the creator of the record (cmid = lmid) and has create priveleges (p="C") ' (4) A new record is being created (cmid=NULL) and the logged in member has create priveleges (p="C") ''' AllowChanges = False Select Case GetPermission( trc, lmid, permission ) Case "*" AllowChanges = True Case "W" AllowChanges = True Case "C" ''' ' if the logged in user is the creating member or a new record (no creator) ' is being created then allow changes. ''' If IsNull(cmid) Or IsEmpty(cmid) Or Len(cmid)=0 Then AllowChanges = True Else If CLng(cmid) = CLng(lmid) Then AllowChanges = True Else AllowChanges = False End If End If Case Else AllowChanges = False End Select End Function Function DeleteMember( ByRef trc, mmid, memail, mpassword) ''' ' This routine runs when a member requests his membership be deleted. See the ' DeleteMemberAdmin (below) to directly delete a member. ' mid = Session("MemberID") = the currently signed-in member. Member must be signed-in to delete. ' memail = Request.Form("MEmail") = the user must enter their email address and password to delete. ' mpassword = Request.Form("MPassword") ''' Dim rs, msg, subj DeleteMember = False If (Not ValidMember(trc, mmid)) Or (Not ValidEmail(memail)) Or Len(mpassword)=0 Then Call AddMessageError( "Membership could not be deleted.
" & _ "You must be signed in to delete your membership.
" & _ "Please be sure you entered the correct email sign-in address and password.
" ) Exit Function End If Set rs = trc.Execute("SELECT MEmail, MPassword FROM Members WHERE MID = " & mmid ) If rs.EOF Then Call AddMessageError("Membership record could not be found." ) rs.Close Exit Function End If If ValidSignIn( trc, memail, mpassword ) Then ''' ' it's okay to delete membership ''' Call MemberSignOut ''' ' send confirmation email ''' msg = "Dear Member:" & vbCrLf & vbCrLf & _ "Per your request, your membership on TeamRoper.com has been deleted. Thank you for using " & _ "our site and we hope you'll visit again. " & vbCrLf & vbCrLf & _ "Member Sign-In Email: " & memail & vbCrLf & vbCrLf & _ "Sincerely, " & vbCrLf & _ "TeamRoper.com" subj= "TeamRoper.com Membership Removed." Call SendMemberEmail( trc, mmid, "", subj, msg ) ''' ' delete member records ''' Call DeleteMemberAdmin( trc, mmid ) DeleteMember = True End If End Function Sub DeleteMemberAdmin( ByRef trc, mmid ) ''' ' remove trading arena and events associated with member. ' FUTURE: add code to remove image files associated with ads ''' If Not ValidID( mmid ) Then Exit Sub trc.Execute("DELETE FROM Events WHERE EVMID = " & mmid ) trc.Execute("DELETE FROM TradingPostAds WHERE TPMID = " & mmid ) trc.Execute("DELETE FROM ContestEntry WHERE CEMID = " & mmid ) trc.Execute("DELETE FROM Members WHERE MID = " & mmid ) trc.Execute("DELETE FROM MemberPermissions WHERE MPMID = " & mmid ) Session("MessageError") = Session("MessageError") & "Membership removed.
" End Sub Function MemberDetail( ByRef trc, mid ) ''' ' lists out all the fields in the Members table for a given member id (mid) ' lists out all the member permissions too ''' Dim s, fld s = Empty MemberDetail = Empty If Len(mid)=0 Or IsNull(mid) Then Exit Function Set rs = trc.Execute("SELECT * FROM Members WHERE MID = " & mid ) If Not rs.EOF Then s = "
" & _ "" For Each fld In rs.Fields s = s & "" & _ "" & _ "" Next End If rs.Close MemberDetail = s & "
" & _ "

" & _ "" & _ fld.Name & "

" & _ "

" & _ "" & _ fld.Value & "

" End Function Function ListMemberAds( ByRef trc, mmid ) ''' ' Lists out the titles of ads, ropings, events and so forth that are associated ' with a member ID. ''' Dim rs, s s = "
" & _ "" & _ "" & _ "
" & _ "

" & _ "" If Not ValidID( mmid ) Then s = s & "Invalid Member ID. Can not list ads." Else s = s & "
Trading Arena Ads:

" Set rs = trc.Execute("SELECT TPTitle FROM TradingPostAds WHERE TPMID=" & mmid ) If rs.EOF Then s = s & "No advertisements found.
" Do While NOT rs.EOF s = s & rs("TPTitle") & "
" rs.MoveNext Loop rs.Close s = s & "
Events:

" Set rs = trc.Execute("SELECT EVName FROM Events WHERE EVMID=" & mmid ) If rs.EOF Then s = s & "No events found.
" Do While NOT rs.EOF s = s & rs("EVName") & "
" rs.MoveNext Loop rs.Close s = s & "
Discussion Postings:
" & _ "Discussion group postings will not be deleted.

" Set rs = trc.Execute("SELECT POTitle FROM R2RPostings WHERE POMID=" & mmid ) If rs.EOF Then s = s & "No discussion items found.
" Do While NOT rs.EOF s = s & rs("POTitle") & "
" rs.MoveNext Loop rs.Close End If ListMemberAds = s & "

" End Function Sub SendMemberEmail( ByRef trc, mid, memail, subject, body ) Dim JMail, SendMail If Len(memail) = 0 Or IsEmpty( memail ) Or IsNull( memail ) Or Instr( memail, "@") = 0 Then If IsNull(mid) Or IsEmpty(mid) Or Len(mid) = 0 Then Exit Sub Else Set rs = trc.Execute("SELECT MEmail FROM Members WHERE MID = " & mid ) memail = rs("MEmail") rs.Close End If End If Call MessageLog( trc, "I", "Sending mail to: " & memail ) Set JMail = Server.CreateObject("JMail.SMTPMail") JMail.ServerAddress = "mail.prwebstudio.com" JMail.Sender = "teamroper@teamroper.com" JMail.SenderName = "Support Staff @ TeamRoper.com" JMail.AddRecipient memail JMail.Subject = subject JMail.Body = body JMail.Priority = 3 JMail.LazySend = True JMail.Execute JMail.Close End Sub Sub SendEmail( ByRef trc, remail, sname, semail, subject, body ) ''' ' trc = database connection object ' remail = recipients email address ' sname = sender's name ' semail = sender's email address ' subject = message subject ' body = message body text ''' Dim JMail, SendMail If Not ValidEmail(remail) Then Exit Sub Call MessageLog( trc, "I", "Sending mail to: " & remail ) Set JMail = Server.CreateObject("JMail.SMTPMail") JMail.ServerAddress = "mail.prwebstudio.com" JMail.Sender = semail JMail.SenderName = sname JMail.AddRecipient remail JMail.Subject = subject JMail.Body = body JMail.Priority = 3 JMail.LazySend = True JMail.Logging = True If Not JMail.Execute Then Call MLogEmailErrors( trc, jmail ) JMail.Close End Sub Sub MLogEmailErrors( ByRef trc, ByRef jmail ) Call MessageLog( trc, "F", "Email failure. Error codes follow.") Call MessageLog( trc, "F", "Error Code: " & JMail.ErrorCode) Call MessageLog( trc, "F", "Error Message: " & JMail.ErrorMessage) Call MessageLog( trc, "F", "Error Source: " & JMail.ErrorSource) Call MessageLog( trc, "F", "Server Address: " & JMail.ServerAddress) Call MessageLog( trc, "F", "Server Port: " & JMail.ServerPort) End Sub Function SendPassword( ByRef trc, memail ) ''' ' looks up the password for the given user account (memail) and sends the ' password to that account via email ''' Dim rs, msg SendPassword = False memail = LCase(Trim(memail)) If Instr( memail, "." )=0 Or Instr( memail, "@" )=0 Or Len(memail) < 3 Then AddMessageError("Please enter a valid email address.") Exit Function End If Set rs = trc.Execute( "SELECT MID, MLastName, MFirstName, MEMail, MPassword FROM Members WHERE " & _ "LOWER(MEMail) = '" & memail & "' " ) If rs.EOF Then AddMessageError("The email address you entered could not be found on our system.") rs.Close Exit Function End If Do While Not rs.EOF msg = "Dear " & rs("MFirstName") & " " & rs("MLastName") & " : " & vbCrLf & vbCrLf & _ "As requested, your login name and password are shown below: " & vbCrLf & vbCrLf & _ "Login Name: " & rs("MEMail") & vbCrLf & _ "Password: " & rs("MPassword") & vbCrLf & vbCrLf & _ "Please note that your login name is the same as your email address. " & vbCrLf & vbCrLf & _ "If you've received this email message in error, please disregard and delete it." & vbCrLf & vbCrLf & _ "Sincerely," & vbCrLf & _ "The TeamRoper.com Support Staff" & vbCrLf Call SendMemberEmail( trc, rs("MID"), rs("MEMail"), "TeamRoper.com", msg ) AddMessageError( "Password sent to: " & rs("MEMail") ) rs.MoveNext Loop rs.Close SendPassword = True End Function Sub AddMembershipMessage( mmsg ) If Len( Trim( mmsg ) ) > 0 Then _ Session("MembershipMessage") = Session("MembershipMessage") & mmsg & "
" End Sub Sub SignInForm( ByRef trc ) Dim mfname %>
<% If Len(Session("MemberID")) = 0 Or IsNull(Session("MemberID")) Or IsEmpty(Session("MemberID")) Then %> ?Action=SignIn"> <% Else mfname = GetMemberName(trc, Session("MemberID")) mfname = Trim(Mid( mfname, 1, Instr(mfname," "))) %> <% Session("MembershipMessage") = Empty End If %>

Member Sign In

Member Email Address:

Password:

Automatic sign in

Forgot password?

Become A Member!

Hi, <%=mfname%>

<% If Len(Session("MembershipMessage")) > 0 Then %>

<%=Session("MembershipMessage")%>

<% End If%>

Member Services:
Update Membership
Delete Membership
Sign Out

<% End Sub Sub SignInForm2( ByRef trc ) Dim mfname %>
<% If Len(Session("MemberID")) = 0 Or IsNull(Session("MemberID")) Or IsEmpty(Session("MemberID")) Then %> <% Else mfname = GetMemberName(trc, Session("MemberID")) mfname = Trim(Mid( mfname, 1, Instr(mfname," "))) %> <% End If %>
?Action=SignIn">

Sign In Email: Passwd:

Forgot Password  New Member

Hi,   Member Services

<% End Sub Sub SignInForm3( ByRef trc, options ) Dim mfname, PostBackFormURL PostBackFormURL = Request.ServerVariables("SCRIPT_NAME") & "?Action=SignInReturn" If InStr( options, "HOMEPAGELOGIN" ) <> 0 Then PostBackFormURL = "/Default.asp?Action=SignInReturn" End If %>

Member Log In

To sign in, enter the email address and password you provided when you created your TeamRoper account.

Member Email Address: 

Password: 


Auto Sign In

<% End Sub %><% Function ContestEntry( ByRef trc, mmid, coid, coname ) ''' ' Insterts an entry into the ContestEntry table if the user has the correct permissions ' and is eligible. Returns TRUE if contest entry is made, FALSE otherwise ''' Dim sql, rs, rsco, p, medcnt, cnt ContestEntry = False If Len(mmid)=0 Or IsNull(mmid) Then Exit Function If ( Len(coid)=0 Or IsNull(coid) ) AND ( Len(coname)=0 Or IsNull(coname) ) Then Exit Function If Len(coname) > 0 And ( Len(coid)=0 Or IsNull(coid) ) Then coid = COContestIDFromName( trc, coname ) End If ''' ' does the member have permission to enter contests? ''' p = GetPermission( trc, mmid, "MPContests" ) If p <> "Y" Then Exit Function ''' ' old way of excluding TRC affiliates from contests ''' Set rs = trc.Execute("SELECT MTRCAffiliate FROM Members WHERE MTRCAffiliate='Y' AND MID = " & mmid) If Not rs.EOF Then Exit Function rs.Close ''' ' check if contest is active and within valid dates ''' Set rsco = trc.Execute("SELECT * FROM Contests WHERE COID = " & coid ) If rsco.EOF Then Exit Function If rsco("COStatus") <> "ACTIVE" Then Exit Function If Now() < rsco("COStartDate") OR Now() > rsco("COEndDate") Then Exit Function ''' ' Check if the number of entries per day has been exceeded. ''' medcnt = rsco("COMaxEntriesPerDay") If IsNull( medcnt ) Or IsEmpty( medcnt ) Then medcnt = CLng(0) medcnt = CLng(medcnt) cnt = CLng(0) sql = "SELECT COUNT(*) AS CNT FROM ContestEntry WHERE " & _ "CEDate = '" & CStr(Date()) & "' AND " & _ "CEMID = " & CStr(mmid) & " AND " & _ "CECOID = " & coid & " AND " & _ "CEStatus='NEW'" Set rs = trc.Execute(sql) If Not rs.EOF Then If Not( rs("CNT")=0 Or IsNull(rs("CNT")) Or IsEmpty(rs("CNT")) ) Then cnt = CLng(rs("CNT")) End If rs.Close If cnt < medcnt Then ''' ' max entries per day (medcnt) has NOT been exceeded... allow contest entry ''' Randomize sql = "INSERT INTO ContestEntry " & _ "( CEIPAddress, CECOID, CEMID, CEDate, CEContestName, CERandom, CESequence, CEStatus, CEStatusDate ) " & _ "VALUES ( " & _ "'" & Request.ServerVariables("REMOTE_ADDR") & "'," & _ CStr(rsco("COID")) & "," & _ CStr(mmid) & "," & _ "'" & CStr(Date()) & "'," & _ "'" & rsco("COName") & "'," & _ CStr(CLng( 100000 * Rnd + 1 ) ) & "," & _ CStr(COCurrentSequence( trc, coid ) ) & "," & _ "'NEW'," & _ "'" & CStr(Now()) & "')" trc.Execute(sql) ContestEntry = True End If rsco.Close End Function Function COCurrentSequence( ByRef trc, coid ) ''' ' The Contest Entry Sequence number defines a group of entries for a repeating contest. Example: a monthly ' contest would have entries with the same sequence number for a single month. ''' ''' ' First see if there are any existing NEW contest entries. If so, use that sequence number. ' If not, generate a new sequence number ''' Dim rs COCurrentSequence = 1 Set rs = trc.Execute( "SELECT TOP 1 CESequence FROM ContestEntry WHERE CECOID = " & coid & _ "AND CEStatus='NEW' AND CECOID IS NOT NULL ORDER BY CEID DESC " ) If Not rs.EOF Then If Not( IsNull(rs("CESequence")) Or IsEmpty(rs("CESequence")) ) Then COCurrentSequence = rs("CESequence") Exit Function End If End If rs.Close ''' ' If there are no existing records then a new sequence must be created. Look ' for the largest sequence number and add one. ''' Set rs = trc.Execute( "SELECT MAX(CESequence) AS MX FROM ContestEntry" ) If Not rs.EOF Then If Not( IsNull(rs("MX")) Or IsEmpty(rs("MX")) ) Then COCurrentSequence = CLng(rs("MX")) + 1 Exit Function End If End If rs.Close End Function Function COContestIDFromName( ByRef trc, coname ) COContestIDFromName = Null If Len(coname)=0 Or IsNull(coname) Then Exit Function Set rs = trc.Execute("SELECT COID FROM Contest WHERE UPPER(CONAME)='" & UCase(coname) & "'" ) If rs.EOF Then rs.Close Exit Function End If COContestIDFromName = rs("COID") rs.Close End Function %><% Sub EDRecentArticlesHTML( ByRef trc, aplid, cnt ) If Len(cnt) = 0 Or IsNull(cnt) Then cnt = 10 If Len(aplid)=0 Then aplid = 3 Set rs = trc.Execute( "SELECT TOP " & cnt & " EATitle, EAID FROM EdArticles " & _ "WHERE EAStatus = 'NORMAL' AND " & _ "EAAPLID = " & aplid & " AND TOS='P' " & _ "ORDER BY EALastUpdated DESC " ) If rs.EOF Then Exit Sub %>

Recent articles:

<% Do While Not rs.EOF %>
<% End Sub Function EDRecentArticlesRS( ByRef trc, aplid, cnt, options ) Dim rs, orderby If Len(cnt) = 0 Or IsNull(cnt) Then cnt = 10 If Len(aplid)=0 Then aplid = 3 orderby = "" options = UCase(options) If InStr( options, "BY LASTUPDATED" ) <> 0 Then orderby = "ORDER BY EALastUpdated DESC " Else If InStr( options, "BY EAID") <> 0 Then orderby = "ORDER BY EAID DESC " End If sql = "SELECT TOP " & cnt & " EATitle, EAID FROM EdArticles " & _ "WHERE EAStatus = 'NORMAL' AND " & _ "EAAPLID = " & aplid & " AND TOS='P' " & orderby Set rs = Server.CreateObject("ADODB.Recordset") rs.Open sql, trc, adOpenStatic, adLockReadOnly, adCmdText Set EDRecentArticlesRS = rs End Function Sub ITSearchBox %>
?Action=Search">

Search:
">

<% End Sub Sub DNRecentArticles( ByRef trc, cnt ) If Len(cnt) = 0 Then cnt = 10 Set rs = trc.Execute( "SELECT TOP " & cnt & " DAtitle, DADCID FROM DiscussionArticles ORDER BY DALastUpdated DESC" ) If rs.EOF Then Exit Sub %>

Recent discussion:

<% Do While Not rs.EOF %>

?Action=View&SubAction=Category&ID=<%=rs("DADCID")%>" class="GenericTextHyperlinks"> <% Response.Write(Mid( rs("DATitle"), 1, 80 )) %>

<% rs.MoveNext Loop rs.Close %>
<% End Sub Sub TPShowPaidPictureAdsHorizontal( ByRef trc, cnt ) ''' ' Displays a horizontal table with up to "cnt" number of pictures from Ads in the Trading Arena. ' Advertisers in the Trading Arena must pay for ads to be displayed here. Also, the ads must have ' passed the TOS scanner. ' ' cnt = the number of picture ads to be displayed. ''' Dim rs, sql, width, imgurl, rcnt, icnt, tmp If Len(cnt)=0 Or IsNull(cnt) Then cnt = 6 sql = "SELECT TOP " & cnt & " TPID, TPPictureURL, TPUpgradeShows, TPTitle FROM TradingPostAds " & _ "WHERE TPLocationUpgrade='HomePagePicture' AND TPPictureUpgrade='Y' AND TPPictureURL IS NOT NULL AND TOS='P' AND " & _ "TPAdStatus IN ('A','M') ORDER BY TPUpgradeShows ASC" Set rs = Server.CreateObject("ADODB.Recordset") rs.Open sql, trc, adOpenKeyset, adLockOptimistic, adCmdText If rs.EOF Then Exit Sub ''' ' calc width of each cell rcnt = CInt(rs.RecordCount) width = CStr(Int( 100 / rcnt ) ) & "%" %>
<% icnt = 0 Do While Not rs.EOF imgurl = CStr( rs("TPPictureURL") ) icnt = icnt + 1 If icnt = rcnt Then tmp = "border-right: 1 solid #990000; " Else tmp = "" End If %> <% trc.Execute("UPDATE TradingPostAds SET TPUpgradeShows = ISNULL(TPUpgradeShows,0) + 1 WHERE TPID=" & CStr(rs("TPID"))) rs.MoveNext Loop rs.Close %>

Trading Arena Features
For Sale or Trade

"> <%=rs(" align="middle">

<% End Sub Sub TPShowPaidPictureAdsVertical( ByRef trc, cnt ) ''' ' Displays a horizontal table with up to "cnt" number of pictures from Ads in the Trading Arena. ' Advertisers in the Trading Arena must pay for ads to be displayed here. Also, the ads must have ' passed the TOS scanner. ' ' cnt = the number of picture ads to be displayed. ''' Dim rs, sql, imgurl If Len(cnt)=0 Or IsNull(cnt) Then cnt = 6 sql = "SELECT TOP " & cnt & " TPID, TPPictureURL, TPUpgradeShows, TPTitle FROM TradingPostAds " & _ "WHERE TPLocationUpgrade='HomePagePicture' AND TPPictureUpgrade='Y' AND TPPictureURL IS NOT NULL AND TOS='P' AND " & _ "TPAdStatus IN ('A','M') ORDER BY TPUpgradeShows ASC, TPAdStatusDate DESC " sql = "SELECT TPID, TPPictureURL, TPUpgradeShows, TPTitle FROM TradingPostAds " & _ "WHERE TPLocationUpgrade='HomePagePicture' AND TPPictureUpgrade='Y' AND TPPictureURL IS NOT NULL AND TOS='P' AND " & _ "TPAdStatus IN ('A','M') ORDER BY TPUpgradeShows ASC, TPAdStatusDate DESC, TPID ASC" Set rs = trc.Execute(sql) If rs.EOF Then Exit Sub %>
<% Do While Not rs.EOF imgurl = CStr( rs("TPPictureURL") ) %> <% trc.Execute("UPDATE TradingPostAds SET TPUpgradeShows = ISNULL(TPUpgradeShows,0) + 1 WHERE TPID=" & CStr(rs("TPID"))) rs.MoveNext Loop rs.Close %>

Classified Ads
featured Horses for Sale & more

" class="GenericTextHyperlink3"><%=rs(" align="left">
" class="GenericTextHyperlink3"><%=rs("TPTitle")%>
<% End Sub Sub TPShowPaidTextAds( ByRef trc, cnt ) ''' ' Displays a vertical table with up to "cnt" number of titles from Ads in the Trading Arena. ' Advertisers in the Trading Arena must pay for ads to be displayed here. Also, the ads must have ' passed the TOS scanner. ' ' cnt = the number of text ads to be displayed. ''' Dim rs, sql, tmp If Len(cnt)=0 Or IsNull(cnt) Then cnt = 6 ''' ' The first sql statement will show ads by their # of showings... the second one shows ' all ads as a temporary fix for Jim L ''' sql = "SELECT TOP " & cnt & " TPID, TPTitle, TPUpgradeShows FROM TradingPostAds " & _ "WHERE TPLocationUpgrade='HomePageText' AND TOS='P' AND " & _ "TPAdStatus IN ('A','M') ORDER BY TPUpgradeShows ASC, TPID DESC" sql = "SELECT TPID, TPTitle, TPUpgradeShows FROM TradingPostAds " & _ "WHERE TPLocationUpgrade='HomePageText' AND TOS='P' AND " & _ "TPAdStatus IN ('A','M') ORDER BY TPUpgradeShows ASC, TPAdStatusDate DESC" Set rs = trc.Execute(sql) If rs.EOF Then Exit Sub %>

Featured Ads
Sell your Horse here!

<% Do While Not rs.EOF %>

" class="GenericTextHyperlinks"> <%=rs("TPTitle")%>

<% trc.Execute("UPDATE TradingPostAds SET TPUpgradeShows = ISNULL(TPUpgradeShows,0) + 1 WHERE TPID=" & CStr(rs("TPID"))) rs.MoveNext Loop rs.Close %>
<% End Sub %>