<% Session.Timeout = 90 Dim MessageError, trc, rs, pmtid, tpid, tmp Call OpenDBConnections( trc ) Select Case CleanInput(Request.Form("SUBMIT")) Case "Go" ''' ' visitor login If MemberSignIn( trc, CleanEmail(Request.Form("MEMail")), CleanInput(Request.Form("MPassword")) ) Then ''' ' if valid login and user checked auto sign-in box then set auto sign in ''' Call SetAutoSignIn( trc, Session("MemberID"), CleanInput(Request.Form("MAutoSignIn")) ) Call HTMLHeader Call SubPageHeader( "Your Trading Arena Ads" ) Call PageBody( "ViewMemberAds", CleanInput(Request.QueryString("ID")), "" ) Else Call HTMLHeader Call SubPageHeader("Trading Arena - Please Sign In") Call PageBody( "TPShowAds", "", "" ) End If Case "Advertise It" If len(tpid) = 0 Then tpid = CleanInput(Request.Form("TPID")) End If If len(tpmid) = 0 Then tpmid = CleanInput(Request.Form("TPMID")) End If Session("TPEdit") = IIF( IsNull(Request.Form("TPEdit")), False, Request.Form("TPEdit") ) If Session("TPEdit") <> False Then Session("TPEdit") = True If ValidTradingArenaAdData Then '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'u = unpaid p = paid 'if the data is valid we create the Trading Record and flag it with a U '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Call StoreTradingArenaAd( trc, tpid, tpmid, "U") amt = TRGetAdPayment(trc, tpid) Call HTMLHeader If amt > 0 Then If Session("TPEdit") = "True" Then Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Call TPClearSavedSessVars Else If ValidPromotion( trc, Session("PMCode")) Then Call TPUsePromotion(trc, tpid) Else If Len(Session("PMCode")) > 0 Then Call AddMessageError("The promotion code '" & CleanInput(Request.Form("PMCode")) & "' is not valid. You may " & _ "pay via credit card or press your browser's back button and re-enter " & _ "the promotion code." ) End If Call TPUseCreditCard(trc, tpid) End If End If Else Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Call TPClearSavedSessVars End IF Else Call HTMLHeader Call SubPageHeader("New Trading Arena Ad") Call PageBody( "EditAdvertisement", Empty, Session("MemberID") ) End If Case "Upload Complete" Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Call TPClearSavedSessVars Case "Search" If len(Session("TPOrderBy")) = 0 Then Session("TPOrderBy") = "TPDatePlaced DESC" Else If len(CleanInput(Request.QueryString("By"))) > 0 Then Session("TPOrderBy") = CleanInput(Request.QueryString("By")) End If End If If TPValidSearchData Then Call HTMLHeader Call SubPageHeader( "Trading Arena Search Results" ) Call PageBody( "SearchResults", "", "" ) Else Call HTMLHeader Call SubPageHeader( "Trading Arena Search" ) Call PageBody( "", "", "" ) End If Case "Cancel" Select Case Request.QueryString("Action") Case "Delete" Call HTMLHeader Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Case Else Call HTMLHeader Call SubPageHeader( "Trading Arena Search" ) Call PageBody( "SearchCriteria", "", "" ) End Select Case "Confirm" Select Case Request.QueryString("Action") Case "Delete" Call DeleteTradingArenaAd( trc, CleanInput(Request.QueryString("ID")), Session("MemberID") ) Call HTMLHeader Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Case Else End Select Case "Continue" Select Case Request.QueryString("Action") Case "AdUpgrades" If Not MemberSignedIn( trc ) Then tmp = "NoMember" Else If Not TRValidAdUpgrades Then Call TRStoreAdUpgrades( trc, CleanInput(Request.Form("TPID")) ) tmp = "NoUpgrades" Else Call TRStoreAdUpgrades( trc, CleanInput(Request.Form("TPID")) ) If ValidPromotion( trc, CleanInput(Request.Form("PMCode")) ) Then tmp = "UsePromotion" Else If Len(Request.Form("PMCode")) > 0 Then Call AddMessageError("The promotion code '" & CleanInput(Request.Form("PMCode")) & "' is not valid. You may " & _ "pay via credit card or press your browser's back button and re-enter " & _ "the promotion code." ) End If tmp = "UseCreditCard" End If End If End If Select Case tmp Case "NoMember" Call ADdMessageError("Due to a long period of inactivity, your sign-in has expired. Please sign-in again.") Call HTMLHeader Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Call TPClearSavedSessVars Case "NoUpgrades" Call HTMLHeader Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Call TPClearSavedSessVars Case "UsePromotion" ''' ' User has entered a valid promotion code. Pay via promotion. ''' pmtid = CreatePayment( trc, _ Session("MemberID"), _ "TRADINGARENA", _ CleanInput(Request.Form("TPID")), _ 1, _ CDbl( TRGetPayment( trc, CleanInput(Request.Form("TPID"))) ), _ CDbl(0.00), _ CDbl(0.00), _ "TeamRoper.com Trading Arena Ad" ) Call PayByPromotion( trc, CleanInput(Request.Form("PMCode")), pmtid ) Call AddMessageError("Ad paid by promotion code.") Call HTMLHeader Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Call TPClearSavedSessVars Case "UseCreditCard" ''' ' User has entered either no promotion code or an invalid one. If user entered invalid one ' then tell them and ask for CC payment. ''' pmtid = CreatePayment( trc, _ Session("MemberID"), _ "TRADINGARENA", _ CleanInput(Request.Form("TPID")), _ 1, _ CDbl( TRGetPayment( trc, CleanInput(Request.Form("TPID"))) ), _ CDbl(0.00), _ CDbl(0.00), _ "TeamRoper.com Trading Arena Ad Using Credit Card (usecreditcard)" ) Call HTMLHeader Call SubPageHeader("Trading Arena Payment") Call PageBody( "UpgradePayment", pmtid, "" ) Call TPClearSavedSessVars Case Else End Select Case Else End Select Case "Send" If EMValidData Then Call EMSendEMail Call EMClearSessVars( "" ) Call AddMessageError("Email sent.") Response.Redirect( Session("EMReturnURL") ) Else Call HTMLHeader Call SubPageHeader( "Trading Arena Email" ) Call PageBody( "EMForm", "", "" ) End If Case Else Select Case Request.QueryString("Action") Case "Upload" If SetUploaderSessionVariables( CleanInput(Request.QueryString("ID")) ) Then Response.Redirect("/Uploads/GetFile.asp?Action=INIT") Else Call HTMLHeader Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) End If Case "NewAdvertisement" If MemberSignedIn( trc ) Then Session("TPSearchPage") = Empty Call HTMLHeader Call SubPageHeader("New Trading Arena Ad") Call PageBody( "EditAdvertisement", Empty, Session("MemberID") ) Else Call HTMLHeader Call SubPageHeader("Trading Arena - Please Sign In") Call PageBody( "MemberSignIn", "", "" ) End If Case "CCReturn" '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' after the ccform on the creditcards.asp has been submitted and ' has returned successfully this option is called. ' ' pmid is returned from the Credit Card asp and it is the unique id associated ' with and invoice or record ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' pmid = CCProcessorResponse( trc ) tpid = GetSubCategoryID(trc, pmid) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' check if payment is recrived. returns true if pmid is found "PMID=pmid" ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If PaymentReceived( trc, "PMID", pmid ) Then ' unlock the ad in the TradingPostAds table Call UpdateTradingArenaAdPaid( trc, tpid ,Session("MemberID"), "P" ) Call AddMessageError( "Your order has been completed. Thank you!" ) ' unlock file upload If TPAllowUpload( trc, tpid ) Then Call AddMessageError("To upload images, click the 'Upload' link.") End If Call HTMLHeader Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Else Call AddMessageError( "Your credit card could not be processed or was declined.
" & _ "Please try again with the same or different credit card. " ) Call HTMLHeader Call SubPageHeader("Trading Arena Upgrade Payment") Call PageBody( "UpgradePayment", pmid, "" ) End If Case "CCCancel" Call AddMessageError( "Your Trading Arena upgrade/picture order has been cancelled." ) 'Call AddMessageError( "You may upgrade or ad a picture to your ad any time by clicking Edit next to your ad." ) Call HTMLHeader Call DeleteTradingArenaAd(trc, CleanInput(Request.QueryString("ID")), Session("MemberID") ) Call DeletePictureUpload(trc, CleanInput(Request.QueryString("ID")), Session("MemberID") ) Call TPClearSavedSessVars Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Case "Pay" tpid = CleanInput(Request.QueryString("ID")) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' taking the trading post id (tpid) and query the payments table columne pmsubcategoryid. ' ' get the payment id if a record exists. if it does not create one. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' pmtid = PaymentCreated( trc, "TRADINGARENA", tpid) If len(pmtid)= 0 Then Call TPUseCreditCard(trc, tpid) Else Call HTMLHeader Call SubPageHeader("Trading Arena Payment") Call PageBody( "UpgradePayment", pmtid, "" ) End If Case "Advertise" If MemberSignedIn( trc ) Then Session("TPSearchPage") = Empty Call HTMLHeader Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Else Call HTMLHeader Call SubPageHeader("Trading Arena - Please Sign In") Call PageBody( "MemberSignIn", "", "" ) End If Case "EMail" Call EMSetupSessionVarsByApp( trc, "TRADING", CleanInput(Request.QueryString("ID")) ) Call HTMLHeader Call SubPageHeader( "Trading Arena Email" ) Call PageBody( "EMForm", "", "" ) Case "Search" Select Case Request.QueryString("SubAction") Case "Previous" Call HTMLHeader Call SubPageHeader( "Trading Arena Search Results" ) Call PageBody( "PreviousSearchResults", "", "" ) Case Else Call HTMLHeader Call SubPageHeader( "Trading Arena Search Results" ) Call PageBody( "SearchResults", "", "" ) End Select Case "View" Select Case Request.QueryString("SubAction") Case "MemberAds" Call HTMLHeader Call SubPageHeader( "Your Trading Arena Ads" ) Call PageBody( "ViewMemberAds", CleanInput(Request.QueryString("ID")), "" ) Case "AnyPage" Response.Redirect("/AnyPage/Default.asp?Action=View&ID=" & CleanInput(Request.QueryString("ID"))) Case Else Call HTMLHeader Call SubPageHeader( "Trading Arena Detail" ) Call PageBody( "ItemDetail", CleanInput(Request.QueryString("ID")), "" ) End Select Case "MyRanch" Call HTMLHeader Call SubPageHeader("Your Ranch") Select Case Request.QueryString("SubAction") Case "Add" Call TPRanchAddItem(trc, Session("MemberID"), CleanInput(Request.QueryString("ID"))) Case "Remove" Call TPRanchRemoveItem(trc, Session("MemberID"), CleanInput(Request.QueryString("ID"))) Case Else End Select Call PageBody( "ViewMyRanch", CleanInput(Request.QueryString("ID")), "" ) Case "SearchAgent" Call HTMLHeader Call SubPageHeader( "Your Trading Arena Search Agents" ) Call PageBody( "SearchAgent", "", "" ) Case "Edit" If Len(CleanInput(Request.QueryString("ID")))=0 Then tmp = "New Trading Arena Ad" Else tmp = "Edit Trading Arena Ad" End If Call HTMLHeader Call SubPageHeader( tmp ) Call PageBody( "EditAdvertisement", CleanInput(Request.QueryString("ID")), Session("MemberID") ) Case "Delete" Call HTMLHeader Call SubPageHeader( "Trading Arena Search Results" ) Call PageBody( "DeleteRequest", CleanInput(Request.QueryString("ID")), "" ) Case "ChangePage" Select Case Request.QueryString("SubAction") Case "SearchAds" Session("TPSearchAdsPage") = CleanInput(Request.QueryString("Page")) Call HTMLHeader Call SubPageHeader( "Trading Arena Search Results" ) Call PageBody( "SearchResults", "", "" ) Case "MemberAds" Session("TPMemberAdsPage") = CleanInput(Request.QueryString("Page")) Call HTMLHeader Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Case Else End Select Case "Sort" Session("TPOrderBy") = CleanInput(Request.QueryString("By")) Call HTMLHeader Call SubPageHeader( "Trading Arena Search Results" ) Call PageBody( "SearchResults", "", "" ) Case Else Call HTMLHeader Call SubPageHeader( "Trading Arena Search" ) Call PageBody( "SearchCriteria", "", "" ) End Select End Select Sub HTMLHeader %> TeamRoper.com - Buy or Sell your horse & more free! List in our Classifieds! <% End Sub Sub PageBody( Action, Parm1, Parm2 ) ''' ' cc1 = column #1 bgcolor (leftmost column) ' cc2 = column #2 bgcolor (middle column) ' cc3 = column #3 bgcolor (rightmost column) ' cw1 = column #1 width... ''' Dim cc1, cc2, cc3, cw1, cw2, cw3, bdr, bdrc, orderby Call ShowErrorMessage( MessageError ) Select Case Action Case Else ''' ' Default colors and column widths. ''' bdr = "0" : bdrc = "" cw1 = "150" : cw2 = "550" : cw3 = "0%" cc1 = "#FFFFFF" : cc2 = "#FFFFFF" : cc3 = "#FFFFFF" End Select %>
>
<% ''' ' right column actions ''' Select Case Action Case "ViewMemberAds" Call TPSearchOptions( trc ) Call WhiteSpacer(8) Call TPHornsToHeels( trc, 10 ) Call WhiteSpacer(8) Call TPRequestSignIn( trc ) Call WhiteSpacer(8) Response.Write( SimpleHTMLTable( GetAdHTML( trc, NextADIDToView( trc, 8 ) ), "Left", "100%", "margin-left:0;" ) ) Call WhiteSpacer(8) Call TPViewAdCounts( trc ) Case Else Call TPSearchOptions( trc ) Call WhiteSpacer(8) Call TPHornsToHeels( trc, 4 ) Call WhiteSpacer(8) Call TPRequestSignIn( trc ) Call WhiteSpacer(8) Response.Write( SimpleHTMLTable( GetAdHTML( trc, NextADIDToView( trc, 8 ) ), "Left", "100%", "margin-left:0;" ) ) Call WhiteSpacer(8) Call TPViewAdCounts( trc ) End Select %>   <% ''' ' center column actions ''' Select Case Action Case "EMForm" Call EMEmailForm Case "UpgradePayment" Call GeneralMessage( "Please enter your payment information below...", "", "" ) Call CCForm( trc, Parm1 ) Case "AdUpgrades" Call TRShowAdUpgrades( trc, Parm1 ) Case "UploadPictures" If SetUploaderSessionVariables( tpid ) Then Response.Redirect("/Uploads/GetFile.asp?Action=INIT&ID="&Parm1&"&EDIT="&Session("TPEdit")) End If Case "DeleteRequest" Call ConfirmOrCancel( Parm1, "Delete", "Please click 'Confirm' to remove the ad shown below.", "", "" ) Call TPShowItemDetail( Parm1 ) Case "EditAdvertisement" Call TPEditAdvertisement( trc, Parm1, Parm2 ) Case "ViewMemberAds" Call TPShowMemberAds( trc, Session("MemberID"), 15, Session("TPMemberAdsPage") ) Call TPShowMemberAdsHelp Case "SearchAgent" Select Case (Request("SubAction")) Case "SAAdd" Call TPNewMemberSeachAgent( trc, Session("MemberID"), Request("TPSAID")) Case "SAEdit" Call TPNewMemberSeachAgent( trc, Session("MemberID"), Request("TPSAID")) Case "SASave" Call TPSaveMemberSearchAgent( trc, Session("MemberID"), Request("TPSAID")) Call TPShowMemberSeachAgent( trc, Session("MemberID") ) Case "SADelete" Call TPDeleteMemberSeachAgent( trc, Session("MemberID"), Request("TPSAID")) Call TPShowMemberSeachAgent( trc, Session("MemberID") ) Case "SAView" Call TPShowSearchResults( trc, _ SAGetSearchSQL(trc, Session("MemberID"), Request("TPSAID")), _ "", _ 15, _ Session("TPSearchAdsPage"), _ "" ) Case Else Call TPShowMemberSeachAgent( trc, Session("MemberID") ) End Select Case "ViewMyRanch" Call TPShowMyRanch(trc, Session("MemberID")) Case "ItemDetail" Call TPShowItemDetail( Parm1 ) If TPValidEnhancement(trc, Request("ID"), "DisplayAllAds" ) Then orderby = Session("TPOrderBy") Call TPShowSearchResults( trc, TPItemListSQL( trc, Request("ID")),orderby,15, Session("TPSearchAdsPage"), "MemberAds" ) End If Case "PreviousSearchResults" orderby = Session("TPOrderBy") Call TPShowSearchResults(trc,TPSearchSQL,orderby,15,Session("TPSearchAdsPage"), "" ) Case "SearchResults" Call TPSearchCriteria orderby = Session("TPOrderBy") Call TPShowSearchResults(trc,TPSearchSQL,orderby,15,Session("TPSearchAdsPage"), "" ) Case Else Call TPSearchCriteria orderby = Session("TPOrderBy") Call TPShowSearchResults(trc,TPSearchSQL,orderby,15,Session("TPSearchAdsPage"), "" ) End Select %> <% ''' ' right column actions ''' Select Case Action Case "SearchResults" Case Else Response.Write( GetAdHTML( trc, NextADIDToView( trc, 7 ) ) ) End Select %>
<% End Sub Sub TPUsePromotion(trc, tpid) amt = TRGetAdPayment( trc, tpid ) pmtid = CreatePayment( trc, _ Session("MemberID"), _ "TRADINGARENA", _ tpid, _ 1, _ CDbl(amt), _ CDbl(0.00), _ CDbl(0.00), _ "TeamRoper.com Trading Arena Ad" ) Call PayByPromotion( trc, Session("PMCode"), pmtid ) Call UpdateTradingArenaAdPaid( trc, tpid, Session("MemberID"), "P" ) Call AddMessageError("Ad paid by promotion code.") Call HTMLHeader Call SubPageHeader("Your Trading Arena Ads") Call PageBody( "ViewMemberAds", "", "" ) Call TPClearSavedSessVars End Sub Sub TPUseCreditCard(trc, tpid) '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' User has entered either no promotion code or an invalid one. If user entered invalid one ' then tell them and ask for CC payment. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' amt = CDBl(0.00) If len(tpid) = 0 Then tpid = CleanInput(Request.Form("TPID")) End If If NOT ValidID(tpid) Then amt = TRGetAdPayment( trc, CleanInput(Request.Form("TPID")) ) Else amt = TRGetAdPayment( trc, tpid) End If pmtid = CreatePayment( trc, _ Session("MemberID"), _ "TRADINGARENA", _ tpid, _ 1, _ CDbl( amt ), _ CDbl(0.00), _ CDbl(0.00), _ "TeamRoper.com Trading Arena Ad!" ) Call HTMLHeader Call SubPageHeader("Trading Arena Upgrade Payment") Call PageBody( "UpgradePayment", pmtid, "" ) Call TPClearSavedSessVars End Sub Sub TPHornsToHeels( ByRef trc, reccount ) Dim rs, tmarg marg = 10 Set rs = AnyPageHyperlinksRS( trc, 2, reccount ) If rs.EOF Then Exit Sub %>

Horns to Heels
<% Do While Not rs.EOF %>

" class="GenericTextHyperlinks"> <% Response.Write(Mid( rs("APHyperlinkTitle"), 1, 80 )) %>

<% tmarg = 3 rs.MoveNext Loop %>
<% rs.Close End Sub Function GetSubCategoryID(trc, pmid) dim rs, tpid tpid = 0 sql = "Select * from payments where pmid =" & pmid Set rs = trc.Execute(sql) If NOT rs.EOF Then tpid = rs("pmsubcategoryid") End If rs.close GetSubCategoryID = tpid End Function %> <% '-------------------------------------------------------------------- ' 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 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 %> <% 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 %> <% Function SelectList( Connection, TableName, ColumnName, ListName, Selected ) ''' ' A table in the database named "SelectLists" contains selection values for various fields of various tables. ' Example: the "Customer" table might have a "CustomerType" field which has only 3 possible values such as ' "LOCAL", "UNITED STATES" and "INTERNATIONAL". The SelectLists table would have entries as follows: ' ' SLID SLTableName SLColumnName SLValue SLText SLDisplayOrder ' 11 Customer CustomerType L Local 1 ' 12 Customer CustomerType U USA 2 ' 13 Customer CustomerType I International 3 ' ' This routine looks for the SelectLists table and creates an HTML " & vbCrLf Do While Not rs.EOF If CStr(Selected) = CStr(rs("SLValue")) Then s = s & "" & vbCrLf Else s = s & "" & vbCrLf End If rs.MoveNext Loop s = s & "" & vbCrLf SelectList = s End Function Function TableLookup( ByRef trc, tablename, returncolumn, searchcolumn, value ) Dim sql, rs If IsNull(value) Or IsEmpty(value) Or Len(value)=0 Or value = "**" Or value = "??" Then TableLookup = Empty Exit Function End If sql = "SELECT " & returncolumn & " FROM " & tablename & " WHERE " & searchcolumn & " = '" & value & "'" Set rs = trc.Execute(sql) If rs.EOF Then TableLookup = Empty Else TableLookup = rs( returncolumn ) End If rs.Close End Function Function DatabaseSelectList( ByRef trc, ListName, Selected, TableName, ValueColumn, SelectColumn, OrderColumn ) ''' ' This function creates an HTML " & vbCrLf If IsNull(Selected) Or IsEmpty(Selected) Then Selected = " " Do While Not rs.EOF If CStr(Selected) = CStr(rs(ValueColumn)) Then s = s & "" & vbCrLf Else s = s & "" & vbCrLf End If rs.MoveNext Loop s = s & "" & vbCrLf DatabaseSelectList = s End If rs.Close End Function Function RecordsetSelectList( ByRef rs, _ ListName, _ DisplayColumn, _ ValueColumn, _ SelectedValue, _ NoSelectText, _ NoSelectValue ) ''' ' This function returns an HTML list which represents "no selection" ' NoSelectValue = the value returned when the user selects the "NoSelectText" entry ' ' If NoSelectText is empty or null then the "no selection" entry is not provided. ''' Dim s, sel If rs.EOF Or Len(DisplayColumn) < 1 Or Len(ValueColumn) < 1 Or Len(ListName) < 1 Then RecordsetSelectList = "" Else sel = False rs.MoveFirst s = "" & vbCrLf RecordsetSelectList = s rs.MoveFirst End If End Function Function StateSelectList( ByRef trc, selname , selected, srch, scode ) ''' ' selname = the form name of the " & vbCrLf StateSelectList = selstr rs.Close End Function Function StateRegionSelectList( ByRef trc, selname, selected, srch ) Dim rs If selname = "" Then selname = "StateRegion" If IsNull( srch ) Or IsEmpty( srch ) Then srch = True If Len(selected) = 0 Or IsNull(selected) Then If srch Then selected = "**" Else selected = "??" End If Else selected = UCase(selected) End If If srch Then Set rs = trc.Execute("SELECT * FROM StateRegions WHERE SRCode<>'??' ORDER BY SROrder") Else Set rs = trc.Execute("SELECT * FROM StateRegions WHERE SRCode<>'**' ORDER BY SROrder") End If If Not rs.EOF Then rs.MoveFirst s = "" & vbCrLf StateRegionSelectList= s Else StateRegionSelectList= "" End If 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 %> <% 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 %> <% ''' ' Dependencies: ' StringHandling.asp ' ErrorHandling.asp ' AllPages.asp ' FileHandling.asp ' CreditCards.asp ' ' Trading Arena Ad Statuses ' A = active ' D = deleted ' M = email expriation notification sent ' ''' Sub TPShowSearchResults( ByRef trc, sql, orderby, pagesize, currentpage, returnto ) ''' ' Shows a list of trading arena items. ' sql = sql statement extracting records from the 'TradingPostAds' table ' orderby = the table column name to sort by ' pagesize = the number of items to display on a page ' current page = the current page number being viewed. ' ''' Dim totalpages, rs, linecnt, ImageURL, bcolor If Len(pagesize)=0 Or pagesize=0 Then pagesize = 15 If Len(currentpage)=0 Or currentpage=0 Then currentpage=1 If Len(orderby)=0 Then orderby=" TPDatePlaced DESC " 'If Len(sql)=0 Or Instr( sql, "SELECT")=0 Then sql = "SELECT * FROM TradingPostAds" If Len(sql)=0 Or Instr( sql, "SELECT")=0 Then sql = "SELECT * FROM TRADINGPOSTADS WHERE TPADPAID = 'P'" sql = sql & " ORDER BY " & orderby linecnt = 1 Set rs = Server.CreateObject("ADODB.Recordset") rs.CursorLocation = adUseClient rs.Open sql, trc, , , adCmdText If Not rs.EOF Then rs.PageSize = pagesize totalpages = rs.PageCount If CInt( currentpage ) > totalpages Then currentpage = 1 rs.AbsolutePage = currentpage Else totalpages = 0 End If If Len(returnto) = 0 Then returnto = "SearchAds" If totalpages > 0 Then Response.Write( SimpleHTMLTable( PageNumbers( totalpages, currentpage, returnto ), "Left", "550", "margin-left:10;") ) %>
<% If totalpages > 0 Then %> <% Else %> <% End If Do While NOT rs.EOF And linecnt <= rs.PageSize If bcolor <> "#E6E6E6" Then bcolor = "#E6E6E6" Else bcolor = "#FFFFFF" End If ImageURL = TradingImageURL( trc, rs("TPID") ) If IsEmpty(ImageURL) Then ImageURL = "/Images/NoPic.gif" %> <% linecnt = linecnt + 1 rs.MoveNext Loop %>
?Action=Sort&SubAction=TradingAd&By=TPTitle"> Ad Title ?Action=Sort&SubAction=TradingAd&By=TPPrice"> Price ?Action=Sort&SubAction=TradingAd&By=TPState"> State ?Action=Sort&SubAction=TradingAd&By=TPSellOrWant"> Sell/Want Pic?
No Trading Ads Were Found
?Action=View&SubAction=TradingAd&ID=<%=rs("TPID")%>"> <%=Server.HTMLEncode(rs("TPTitle"))%>   <% If IsNumeric(rs("TPPrice")) Then Response.Write("$" & FormatNumber(rs("TPPrice"),2)) Else Response.Write(rs("TPPrice")) End If %>   <%=rs("TPState")%>  <%=rs("TPSellOrWant")%>  ?Action=View&SubAction=TradingAd&ID=<%=rs("TPID")%>">
<% If totalpages > 0 Then Response.Write( SimpleHTMLTable( PageNumbers( totalpages, currentpage, "SearchAds" ), "Left", "550", "margin-left:10;" ) ) rs.Close End Sub Sub TPShowItemDetail( tpid ) Dim ImageHTML, imgfile2, fs, imgok, rs, PathString, PathArray If Not ValidID( tpid ) Then Exit Sub trc.Execute("UPDATE TradingPostAds SET TPHits = TPHits + 1 WHERE TPID = " & tpid ) ''' ' If there is a location upgrade on this item then increase the hit counter ''' trc.Execute( "UPDATE TradingPostAds SET TPUpgradeHits = ISNULL( TPUpgradeHits, 0 ) + 1 " & _ "WHERE TPID = " & tpid & " AND LEN( ISNULL(TPLocationUpgrade, '') ) > 0 " ) Set rs = trc.Execute("SELECT * FROM TradingPostAds WHERE TPID = " & tpid ) 'ImageHTML = TradingImageURL( trc, rs("TPID") ) PathString = MultipleTradingImageUrl(trc, rs("TPID")) PathArray = split(PathString, ";") For x=0 to UBound(PathArray) ImageHTML = TradingImageHTML( PathArray(x)) If Not IsEmpty(ImageHTML) Then %>
<%=ImageHTML%>
<% End If Next rs.MoveFirst %>
" color="#990000"> <% If rs("TPAdType") > 1 Then Response.Write("") %> <%=Server.HTMLEncode(rs("TPTitle"))%> <% If rs("TPAdType") > 1 Then Response.Write("") %>
<% If Len(rs("TPEmail")) > 0 And Instr(rs("TPEmail"), "@") > 0 Then %> <% End If %>

Price:

<% If IsNumeric(rs("TPPrice")) Then Response.Write("$" & FormatNumber(rs("TPPrice"),2)) Else Response.Write(rs("TPPrice")) End If %>  

Description:

<%=CRtoBR(Server.HTMLEncode(BRtoCR(rs("TPDescription"))))%>

Contact Name: 

<%=rs("TPContactName")%> 

Contact Phone: 

<%=FormatPhone(rs("TPContactPhone"))%> 

Contact E-Mail: 

<%=EMEmailLink( rs("TPEmail"), "EMail", "TRADING", rs("TPID") ) %> 

State Located: 

<% Response.Write ( TableLookup( trc, "States", "StateName", "StateCode", rs("TPState") ) ) If Len(rs("TPStateRegion")) > 0 And ( Not IsNull(rs("TPStateRegion"))) Then Response.Write( " (" & TableLookup( trc, "StateRegions", "SRText", "SRCode", rs("TPStateRegion") ) & ")" ) End If %>  

City: 

<%=rs("TPCity")%> 

Ad Number: 

<%=CStr(rs("TPAdNumber"))%> 

Add To My Ranch: 

?Action=MyRanch&SubAction=Add&ID=<%=rs("TPAdNumber")%>" class="GenericTextHyperlink2">Add    

Video:

<% If len(rs("TPObject")) > 0 Then response.Write(HTMLDecode(rs("TPObject"))) Else response.Write("No Video") End If %>

<%If len(rs("TPChild")) > 0 Then %>
The Pedigree area is the opportunity for you to view the heritage of an animal. Be sure to ask for documentation from the seller to support the pedigree displayed.
            Sire:
Sire:   <%=rs("TPGPParent3111")%> 
        <%=rs("TPPParent11")%>  Dam:
    Sire:   <%=rs("TPGPParent3112")%> 
    <%=rs("TPCParent1")%>      Sire:
    Dam:   <%=rs("TPGPParent3121")%> 
    <%=rs("TPPParent12")%>  Dam:
Horse and Gender       <%=rs("TPGPParent3122")%> 
<%=rs("TPChild")%>          Sire:
      Sire:   <%=rs("TPGPParent3211")%> 
      <%=rs("TPPParent21")%>  Dam:
Dam: <%=rs("TPGPParent3212")%> 
  <%=rs("TPCParent2")%>      Sire:
      Dam:   <%=rs("TPGPParent3221")%> 
      <%=rs("TPPParent22")%>  Dam:
          <%=rs("TPGPParent3222")%> 
<%End If %>
<% End Sub Sub TPShowMemberAds( ByRef trc, mid, pagesize, currentpage ) ''' ' Shows a list of trading arena items. ' sql = sql statement extracting records from the 'TradingPostAds' table ' orderby = the table column name to sort by ' pagesize = the number of items to display on a page ' current page = the current page number being viewed. ' ' requires: StringHandling.asp ''' Dim totalpages, rs, linecnt, ImageURL If Not ValidID( mid ) Then Call GeneralMessage( "Your sign-in has expired due to inactivity. Please re-sign-in to view your ads.", "", "" ) Exit Sub End If If Len(pagesize)=0 Or pagesize=0 Then pagesize = 15 If Len(currentpage)=0 Or currentpage=0 Then currentpage=1 linecnt = 1 sql = "SELECT TPID, TPHits, TPAdNumber, TPTitle FROM TradingPostAds " & _ "WHERE TPMID = " & mid & " AND TPAdStatus IN ('M','A') ORDER BY TPDatePlaced DESC " Set rs = Server.CreateObject("ADODB.Recordset") rs.CursorLocation = adUseClient rs.Open sql, trc, , , adCmdText If Not rs.EOF Then rs.PageSize = pagesize totalpages = rs.PageCount If CInt( currentpage ) > totalpages Then currentpage = 1 rs.AbsolutePage = currentpage Else totalpages = 0 End If If totalpages > 0 Then Response.Write( SimpleHTMLTable( PageNumbers( totalpages, currentpage, "MemberAds" ), "Left", "550", "margin-left:10;" ) ) %>
<% If totalpages > 0 Then %> <% Else %> <% End If Do While NOT rs.EOF And linecnt <= rs.PageSize ImageURL = TradingImageURL( trc, rs("TPID") ) If IsEmpty(ImageURL) Then ImageURL = "/Images/NoPic.gif" %> <% linecnt = linecnt + 1 rs.MoveNext Loop %>

Ad Title

Hits

Pic.

Action

You currently have no active Trading Ads on TeamRoper.com.

?Action=Edit"> Click here to create a new advertisement.

<%=rs("TPTitle")%>  <%=rs("TPHits")%>  ">

?Action=Edit&ID=<%=rs("TPID")%>" class="GenericTextHyperlink2">Edit   ?Action=Delete&ID=<%=rs("TPID")%>" class="GenericTextHyperlink2">Remove   ?Action=View&ID=<%=rs("TPID")%>" class="GenericTextHyperlink2">View   <%If TPAllowUpload( trc, rs("TPID") ) Then %> ?Action=Upload&ID=<%=rs("TPID")%>" class="GenericTextHyperlink2">Upload   <% End If If PaymentReceived( trc, "TRADINGARENA", rs("TPID")) = "False" Then %> ?Action=Pay&ID=<%=rs("TPID")%>" class="GenericTextHyperlink2">Pay   <% End If %>

<% If totalpages > 0 Then Response.Write( SimpleHTMLTable( PageNumbers( totalpages, currentpage, "MemberAds" ), "Left", "550", "margin-left:10;" ) ) rs.Close Set rs = Nothing End Sub Sub TPShowMemberAdsHelp %>

Help:

Click Edit to change the text of your advertisement.

Click View to view your ad as other people would see it.

Click Upload to upload a picture for your advertisement.

Click Remove to delete your advertisement.

Click Pay to pay for your advertisement.

<% End Sub Sub TPShowMemberSeachAgent(ByRef trc, mmid) Dim rs, sql, SAQuantity If Not ValidID( mmid ) Then Call GeneralMessage( "Your sign-in has expired due to inactivity. Please re-sign-in to view your ads.", "", "" ) Exit Sub End If SAQuantity = 5 sql = "SELECT TPSAID, TPSAMID, TPSATitle, TPSADescription FROM TradingPostSearchAgents " & _ "WHERE TPSAMID= '" & mmid & "' ORDER BY TPSADatePlaced DESC " Set rs = Server.CreateObject("ADODB.Recordset") rs.Open sql, trc %> <%If rs.EOF Then%> <% Else Do while NOT rs.EOF %> <% rs.MoveNext Loop End If %>

Agent Title

Description  

Action

You currently have no active Search Agents on TeamRoper.com.

  <%=rs("TPSATitle")%>  <%=rs("TPSADescription")%>  ">  

?Action=SearchAgent&SubAction=SAEdit&TPSAID=<%=rs("TPSAID")%>" class="GenericTextHyperlink2">Edit   ?Action=SearchAgent&SubAction=SADelete&TPSAID=<%=rs("TPSAID")%>" class="GenericTextHyperlink2">Remove   ?Action=SearchAgent&SubAction=SAView&TPSAID=<%=rs("TPSAID")%>" class="GenericTextHyperlink2">View  

?Action=SearchAgent&SubAction=SAAdd"> Click here to create a new agent.

<% End Sub Sub TPNewMemberSeachAgent(ByRef trc, mmid, tpsaid) dim tpsatitle, tpsadescription , sql If len(tpsaid) <> 0 Then Set rs = Server.CreateObject("ADODB.Recordset") sql = "Select * from TradingPostSearchAgents where tpsaid= "& tpsaid rs.open sql, trc If NOT rs.EOF Then tpsatitle = rs("tpsatitle") tpsadescription = rs("tpsadescription") End If End If %>

Agent Title

   
?Action=SearchAgent&SubAction=SASave">
  Agent Title:

 
  Key Words

 
     
  * When creating an agent be very specific regarding the key words that describe you item wanted. The agents will run at night and email you with any matches. Avoid using word that in with "ing", "ed".  Used key word like "Yellow" or "Heel".  To produce a wider search use less key word.  
<% End Sub Sub TPDeleteMemberSeachAgent( ByRef trc, mmid, tpsaid) trc.Execute("DELETE FROM TradingPostSearchAgents WHERE TPSAID= " & tpsaid& " AND TPSAMID = " & mmid ) Call AddMessageError( "Trading Arena advertisement was removed." ) End Sub Sub TPSaveMemberSearchAgent(ByRef trc, tpsamid, tpsaid ) Set rs = Server.CreateObject("ADODB.Recordset") If Not ValidID( tpsamid) Then Call MessageLog( trc, "F", "MemberID (tpsamid) not set on entry to Trading Arena. Search Agent not saved.") Exit Sub End If If len(tpsaid)= 0 Then rs.Open "TradingPostSearchAgents",trc, adOpenKeyset, adLockPessimistic, adCmdTable rs.AddNew Else sql = "Select * from TradingPostSearchAgents where tpsaid= "& tpsaid rs.Open sql, trc, adOpenKeyset, adLockPessimistic, adCmdText End If rs("tpsamid") = tpsamid rs("tpsatitle") = CleanInput(Trim(Request("TPSATitle"))) rs("tpsadescription")= CleanInput(BRtoCR(Trim(Request("TPSADescription")))) rs("tpsadateplaced") = Now() rs.Update tpsaid = rs("TPSAID") rs.Close End Sub Sub TPEditAdvertisement( ByRef trc, tpid, mmid ) Dim fields(5), values(5) ''' ' This routine displays a form for creating or updating a trading arena ad ''' If Not AllowChanges( trc, Null, mmid, "MPTrading" ) Then Call GeneralMessage( "Either you to not have permission to edit this advertisement or you are not signed in.  " & _ "Please sign in before editing advertisements.", "", "" ) Exit Sub End If Call GetTradingArenaDatabaseData( trc, tpid, mmid ) If Len(Session("TPContactName")) < 2 Or IsNull(Session("TPContactName")) Then Session("TPContactName") = GetMemberName( trc, mmid ) fields(0) = "MID" values(0) = mmid fields(1) = "MPhone1" fields(2) = "MEmail" fields(3) = "MCity" fields(4) = "MState" Call GetMemberInfo( trc, fields, values ) Session("TPContactPhone") = values(1) Session("TPEmail") = values(2) Session("TPState") = values(4) Session("TPCity") = values(3) End If %>
" name="Advertise"> <% ''' ' If the ad has been paid for do not allow them to edit any types or enhancements ''' If len(tpid) = 0 Then %>
Ad Type PHOTO TIPS!!
  BASIC: onclick="disableField()" >
$4.99		  

View Larger
 
  • Text ad with email link
  • Full Description
  • 4 week Ad


  
  ECONOMY: onclick="enableField()">
$9.99 		 

View Larger
 
Includes features of "Basic" Ad plus...
  • 1 color photo
  • Bold title
  • 4 week Ad
  
  PREMIUM: onclick="enableField()">
$24.99 		 

View Larger
  Includes features of
"Economy" Ad plus...
  • Bold title
  • Photo featured on home page
  • 4 week Ad
  
<% Else %> "> <% End If %>

Ad Enhancements

  
Additional photo: > Add an additional photo to your ad for $5.00
Member matcher: > Automatically email your ad to members who are looking for a similar product. $9.99
TeamRoper E-Newsletter: > Feature your ad in the TeamRoper.com Member E-Newsletter. $24.99
Additional week:

<%=TPGetDurationSelectList("TPDurationID", Session("TPDurationID"))%>

Add additional week(s) to your ad for $5.00 per week.

Ad Title & Category

  

Select a category for your ad: 

<%=TPGetCategorySelectList("TPCategoryID", Session("TPCategoryID"))%> 

Enter the title for your ad here:

">
The ad title is what buyers will see first.  Maximum 45 characters.  Please be descriptive but brief.

Contact Information

  
Name: ">
Phone number: ">
Email address: ">
Web page address (optional): ">

Item Description

  
Describe the item:
( 50 lines maximum)

Item Video

  
Video the item:
( 50 lines maximum)
For help on posting YouTube video pleas click here
Price: ">
Please enter the price you seek for your item or the word 'TRADE' if you wish to trade.  Describe your trading and pricing conditions in the description box above.

 Pedigree
The Pedigree area is the opportunity for you to display the heritage. The inital grey box is your animal. You should place the gender behind the name seperated by a dash (ie. Max - Male).
            Sire:
Sire:   " />
        " /> Dam:
    Sire:   " />
    " />     Sire:
    Dam:   " />
    " /> Dam:
Horse and Gender       " />
" />         Sire:
      Sire:   " />
      " /> Dam:
Dam: " />
  " />     Sire:
      Dam:   " />
      " /> Dam:
          "/>

 Item Location

  
State: <%=StateSelectList( trc, "TPState", Session("TPState"), False, False)%>
State Region: <%=StateRegionSelectList( trc, "TPStateRegion", Session("TPStateRegion"), False)%>
City: ">
 

If you are selling an item, the location tells the purchaser how far they'll have to travel to obtain it.   If you are looking for an item (want ad) then this location describes where you are.
Promotion Code:

">

 

 
Click here when done:     
<% End Sub Function GetTradingArenaDatabaseData( ByRef trc, tpid, mmid ) Dim sql, rs GetTradingArenaDatabaseData = False If Not ValidID( tpid ) Then Exit Function If Not ValidID( mmid ) Then Call AddMessageError("Please sign-in before editing or placing trading arena ads.") Call MessageLog( trc, "F", "GetTradingArenaDatabaseData: could not find member when retrieving trading arena data." ) Exit Function End If sql = "SELECT * FROM TradingPostAds WHERE TPID = " & tpid & " AND TPMID = " & mmid Set rs = trc.Execute(sql) If rs.EOF Then Call AddMessageError("The advertisement you requested to be edited could not be found. An internal error has occured.") Call MessageLog( trc, "F", "GetTradingArenaDatabaseData: could not find trading arena record.(3)" ) Exit Function End If Call TPClearAdvertiseSessionVariables Session("TPExpireEMail") = rs("TPExpireEMail") Session("TPDuration") = rs("TPDuration") Session("TPTitle") = rs("TPTitle") Session("TPContactName") = rs("TPContactName") Session("TPContactPhone") = rs("TPContactPhone") Session("TPEMail") = rs("TPEMail") Session("TPWeb") = rs("TPWeb") Session("TPPrice") = rs("TPPrice") Session("TPState") = rs("TPState") Session("TPStateRegion") = rs("TPStateRegion") Session("TPCity") = rs("TPCity") Session("TPDescription") = BRtoCR(rs("TPDescription")) Session("TPSellOrWant") = rs("TPSellOrWant") Session("TPCategoryID") = rs("TPCategoryID") Session("TPAdNumber") = rs("TPAdNumber") Session("TPAdExpires") = DateAdd("d", rs("TPDuration"), rs("TPDatePlaced")) Session("TPAdditionalPhoto") = rs("TPAdditionalPhoto") Session("TPItemLists") = rs("TPItemLists") Session("TPMemberMatcher") = rs("TPMemberMatcher") Session("TPDurationID") = rs("TPDurationID") Session("TPAdType") = rs("TPAdType") Session("PMCode") = rs("TPPromotionCode") Session("TPENewsletter") = rs("TPENewsletter") Session("TPObject") = rs("TPObject") Session("TPChild") = rs("TPChild") Session("TPCParent1") = rs("TPCParent1") Session("TPCParent2") = rs("TPCParent2") Session("TPPParent11") = rs("TPPParent11") Session("TPPParent12") = rs("TPPParent12") Session("TPPParent21") = rs("TPPParent21") Session("TPPParent22") = rs("TPPParent22") Session("TPGPParent3111") = rs("TPGPParent3111") Session("TPGPParent3211") = rs("TPGPParent3211") Session("TPGPParent3112") = rs("TPGPParent3112") Session("TPGPParent3212") = rs("TPGPParent3212") Session("TPGPParent3121") = rs("TPGPParent3121") Session("TPGPParent3221") = rs("TPGPParent3221") Session("TPGPParent3122") = rs("TPGPParent3122") Session("TPGPParent3222") = rs("TPGPParent3222") rs.Close GetTradingArenaDatabaseData = True End Function Function ValidTradingArenaAdData Dim um um = Empty ValidTradingArenaAdData = True Session("TPExpireEMail") = CleanEmail(Request.Form("TPExpireEMail")) Session("TPDuration") = CleanInput(Request.Form("TPDuration")) Session("TPTitle") = CleanInput(Trim(Request.Form("TPTitle"))) Session("TPContactName") = CleanInput(Request.Form("TPContactName")) Session("TPContactPhone") = DigitsOnly(Request.Form("TPContactPhone")) Session("TPEMail") = CleanEmail(Trim(Request.Form("TPEMail"))) Session("TPWeb") = CleanURL(Trim(Request.Form("TPWeb"))) Session("TPPrice") = CleanInput(Mid(Trim(Request.Form("TPPrice")), 1, 15)) Session("TPState") = CleanInput(Request.Form("TPState")) Session("TPStateRegion") = CleanInput(Request.Form("TPStateRegion")) Session("TPCity") = CleanInput(Trim(Request.Form("TPCity"))) Session("TPDescription") = CleanHTMLObject(Trim(Request.Form("TPDescription"))) Session("TPObject") = CleanHTMLObject(Trim(Request.Form("TPObject"))) Session("TPSellOrWant") = CleanInput(Request.Form("TPSellOrWant")) Session("TPCategoryID") = CleanInput(Request.Form("TPCategoryID")) Session("TPAdExpires") = DateAdd("d", CleanInput(Session("TPDuration")), Date()) Session("TPID") = CleanInput(Trim(Request.Form("TPID"))) Session("TPMID") = CleanInput(Trim(Request.Form("TPMID"))) Session("TPAdditionalPhoto") = CleanInput(Request.Form("TPAdditionalPhoto")) Session("TPItemLists") = CleanInput(Request.Form("TPItemLists")) Session("TPMemberMatcher") = CleanInput(Request.Form("TPMemberMatcher")) Session("TPDurationID") = CleanInput(Request.Form("TPDurationID")) Session("TPAdType") = CleanInput(Request.Form("TPAdType")) Session("PMCode") = CleanInput(Request.Form("PMCode")) Session("TPENewsletter") = CleanInput(Request.Form("TPENewsletter")) Session("TPChild") = CleanInput(Request.Form("TPChild")) Session("TPCParent1") = CleanInput(Request.Form("TPCParent1")) Session("TPCParent2") = CleanInput(Request.Form("TPCParent2")) Session("TPPParent11") = CleanInput(Request.Form("TPPParent11")) Session("TPPParent12") = CleanInput(Request.Form("TPPParent12")) Session("TPPParent21") = CleanInput(Request.Form("TPPParent21")) Session("TPPParent22") = CleanInput(Request.Form("TPPParent22")) Session("TPGPParent3111") = CleanInput(Request.Form("TPGPParent3111")) Session("TPGPParent3211") = CleanInput(Request.Form("TPGPParent3211")) Session("TPGPParent3112") = CleanInput(Request.Form("TPGPParent3112")) Session("TPGPParent3212") = CleanInput(Request.Form("TPGPParent3212")) Session("TPGPParent3121") = CleanInput(Request.Form("TPGPParent3121")) Session("TPGPParent3221") = CleanInput(Request.Form("TPGPParent3221")) Session("TPGPParent3122") = CleanInput(Request.Form("TPGPParent3122")) Session("TPGPParent3222") = CleanInput(Request.Form("TPGPParent3222")) If Len(Session("TPAdType")) < 1 Then um = um & "Please select an Ad Type for your advertisement.
" ValidTradingArenaAdData = False End If If Session("TPCategoryID") = "0" Or Session("TPCategoryID") = "999" Then um = um & "Please select a category for your advertisement.
" ValidTradingArenaAdData = False End If If Len( Session("TPTitle")) < 2 Then um = um & "Please enter a descriptive (but brief) title for your ad.
" ValidTradingArenaAdData = False End If If Len( Session("TPTitle")) > 50 Then x = CStr(Len(Session("TPTitle")) - 50 ) um = um & "The ad title can be at most 50 characters. The name you entered is " & x & " characters too long. Please shorten it.
" ValidTradingArenaAdData = False End If If Len(Session("TPContactPhone")) > 0 And Len( Session("TPContactPhone") ) <> 10 Then um = um & "Please enter a valid contact phone number. (10 digits)
" ValidTradingArenaAdData = False End If If Len(Session("TPEmail")) > 0 And Not ValidEmail( Session("TPEmail") ) Then um = um & "Please enter a valid email address or leave the email box empty.
" ValidTradingArenaAdData = False End If If Len( Session("TPDescription") ) < 2 Then um = um & "Please enter at least a short description of the item for sale.
" ValidTradingArenaAdData = False End If If Len( Session("TPDescription") ) > 2000 Then x = Int((( Len(Session("TPDescription")) - 2000 ) / 40 ) + 0.5 ) um = um & "Please do not enter more than 50 lines of text. You are currently about " & CStr(x) & " lines over the limit.
" ValidTradingArenaAdData = False End If If Len( Session("TPObject") ) > 1000 Then x = Int((( Len(Session("TPObject")) - 1000 ) / 40 ) + 0.5 ) um = um & "Please do not enter more than 50 lines of text. You are currently about " & CStr(x) & " lines over the limit.
" ValidTradingArenaAdData = False End If If Session("TPState") = "??" Then um = um & "Please select a state where the item is located.
" ValidTradingArenaAdData = False End If If Left( Session("TPWeb"), 7 ) <> "http://" And Len(Session("TPWeb")) > 3 Then Session("TPWeb") = "http://" & Session("TPWeb") End If MessageError = um End Function Sub UpdateTradingArenaAdPaid( ByRef trc, subcatid, mmid, paid ) 'paid is used to flag the record as paid or not. 'p=paid u=unpaid dim l_tpid If Not ValidID( mmid ) Then Call MessageLog( trc, "F", "MemberID (mmid) not set on entry to StoreTradingArenaAd. Ad not updated.") 'UpdateTradingArenaAdPaid = "FAILED" End If if Len(subcatid) > 0 Then Set rs = Server.CreateObject("ADODB.Recordset") rs.Open "SELECT * FROM TradingPostAds WHERE TPID = " & subcatid, trc, adOpenKeyset, adLockPessimistic, adCmdText rs("TPAdPaid") = paid rs.Update rs.Close End If End Sub Sub StoreTradingArenaAd( ByRef trc, ByRef tpid, mmid, paid ) 'paid is used to flag the record as paid or not. 'p=paid u=unpaid Set rs = Server.CreateObject("ADODB.Recordset") If Not ValidID( mmid ) Then Call MessageLog( trc, "F", "MemberID (mmid) not set on entry to StoreTradingArenaAd. Ad not saved.") Exit Sub End If If ValidAdItemList(trc, mmid) Then Session("TPItemLists") = "Y" If Not ValidID( tpid ) Then rs.Open "TradingPostAds", trc, adOpenKeyset, adLockOptimistic, adCmdTable rs.Addnew rs("TPMID") = mmid rs("TPAdNumber") = GetUniqueID( trc, "TR", 5 ) rs("TPHits") = 0 rs("TPUpgradeShows") = 0 rs("TPUpgradeHits") = 0 rs("TPLocationUpgrade") = "NoUpgrade" rs("TPPictureUpgrade") = "N" rs("TPAdPaid") = paid Else rs.Open "SELECT * FROM TradingPostAds WHERE TPID = " & tpid, trc, adOpenKeyset, adLockPessimistic, adCmdText End If rs("TPExpireEMail") = Session("TPExpireEMail") rs("TPDuration") = Session("TPDuration") rs("TPTitle") = Session("TPTitle") rs("TPContactName") = Session("TPContactName") rs("TPContactPhone") = Session("TPContactPhone") rs("TPEMail") = Session("TPEMail") rs("TPWeb") = Session("TPWeb") rs("TPPrice") = Session("TPPrice") rs("TPState") = Session("TPState") rs("TPStateRegion") = Session("TPStateRegion") rs("TPCity") = Session("TPCity") rs("TPDescription") = Session("TPDescription") rs("TPSellOrWant") = Session("TPSellOrWant") rs("TPCategoryID") = Session("TPCategoryID") rs("TPAdStatus") = "A" 'A = active ad rs("TPAdStatusDate") = Now() If Not Session("TPEdit") Then rs("TPDatePlaced") = Date() End If rs("TOS") = "U" 'U = unpaid rs("TPAdditionalPhoto") = Session("TPAdditionalPhoto") rs("TPMemberMatcher") = Session("TPMemberMatcher") rs("TPDurationID") = Session("TPDurationID") rs("TPAdType") = Session("TPAdType") rs("TPPromotionCode") = trim(Session("PMCode")) rs("TPENewsletter")= Session("TPENewsletter") rs("TPItemLists") = Session("TPItemLists") rs("TPChild") = Session("TPChild") rs("TPCParent1") = Session("TPCParent1") rs("TPCParent2") = Session("TPCParent2") rs("TPPParent11") = Session("TPPParent11") rs("TPPParent12") = Session("TPPParent12") rs("TPPParent21") = Session("TPPParent21") rs("TPPParent22") = Session("TPPParent22") rs("TPGPParent3111") = Session("TPGPParent3111") rs("TPGPParent3211") = Session("TPGPParent3211") rs("TPGPParent3112") = Session("TPGPParent3112") rs("TPGPParent3212") = Session("TPGPParent3212") rs("TPGPParent3121") = Session("TPGPParent3121") rs("TPGPParent3221") = Session("TPGPParent3221") rs("TPGPParent3122") = Session("TPGPParent3122") rs("TPGPParent3222") = Session("TPGPParent3222") rs("TPObject") = Server.HTMLEncode(Session("TPObject")) If Session("TPAdType") > 1 or Session("TPAdditionalPhoto") = "Y" Then rs("TPPictureUpgrade") = "Y" rs("TPLocationUpgrade") = "NoUpgrade" End If If Session("TPAdType") > 2 Then rs("TPLocationUpgrade") = "HomePagePicture" End If rs.Update tpid = rs("TPID") Session("TPID") = tpid rs.Close trc.Execute("UPDATE TradingPostAds SET TPUpgradeShows=0") End Sub Sub DeleteTradingArenaAd( ByRef trc, tpid, mmid ) Dim dfn If Len(tpid)=0 Or IsNull(tpid) Or IsEmpty(tpid) Then Call AddMessageError("This advertisement could not be found.") Call MessageLog( trc, "F", "DeleteTradingArenaAd: could not find trading arena record.(1)" ) Exit Sub End If If Len(mmid)=0 Or IsNull(mmid) Or IsEmpty(mmid) Then Call AddMessageError("This advertisement could not be found.") Call MessageLog( trc, "F", "DeleteTradingArenaAd: could not find trading arena record.(2)" ) Exit Sub End If dfn = TradingImageURL( trc, tpid ) Call DeleteFile( dfn ) trc.Execute("DELETE FROM TradingPostAds WHERE TPID= " & tpid & " AND TPMID = " & mmid ) Call AddMessageError( "Trading Arena advertisement was removed." ) End Sub Sub TPSearchOptions( ByRef trc ) %>

Actions:

  ?Action=Search&SubAction=New" class="GenericTextHyperlink2"> New Search

  ?Action=Search&SubAction=Previous" class="GenericTextHyperlink2"> Previous Search

<% If MemberSignedIn( trc ) Then %>

  ?Action=NewAdvertisement" class="GenericTextHyperlink2">Place An Ad

  ?Action=View&SubAction=MemberAds" class="GenericTextHyperlink2">View Your Ads

  ?Action=SearchAgent" class="GenericTextHyperlink2">Search Agents

  ?Action=MyRanch" class="GenericTextHyperlink2">My Ranch

<% End If %>
<% End Sub Sub TPRanchRemoveItem(trc, tprmid, tprid) trc.Execute("DELETE FROM TradingPostRanch WHERE TPRMID= '" & tprmid &"' and TPRID ='"&tprid&"'" ) Call AddMessageError( "Trading Arena advertisement was removed." ) End Sub Sub TPRanchAddItem(trc, tpmid, tpradnumber) dim rs, tprid If Not ValidID( tpmid) Then Call GeneralMessage( "Your sign-in has expired due to inactivity. Please re-sign-in to view your ads.", "", "" ) Exit Sub End If Set rs = Server.CreateObject("ADODB.Recordset") rs.Open "TradingPostRanch",trc, adOpenKeyset, adLockPessimistic, adCmdTable rs.AddNew rs("tprmid") = tpmid rs("tpradnumber") = tpradnumber rs.Update tprid= rs("tprid") rs.Close End Sub Sub TPShowMyRanch(trc, tprmid) Dim rs, sql, SAQuantity If Not ValidID( tprmid ) Then Call GeneralMessage( "Your sign-in has expired due to inactivity. Please re-sign-in to view your ads.", "", "" ) Exit Sub End If sql = "SELECT a.TPAdNumber, a.TPTitle, a.TPDescription, a.TPID, b.TPRID " &_ "FROM TradingPostAds a INNER JOIN TradingPostRanch b ON a.TPAdNumber = b.TPRAdNumber " &_ "WHERE TPRMID= '" & tprmid & "' ORDER BY TPRID DESC " Set rs = Server.CreateObject("ADODB.Recordset") rs.Open sql, trc %> <%If rs.EOF Then%> <% Else Do while NOT rs.EOF %> <% rs.MoveNext Loop End If%>

Ad Title

Description  

Action

You currently have no items stored in your Ranch.

  <%=rs("TPTitle")%>  <%=rs("TPDescription")%>   

?Action=View&ID=<%=rs("TPID")%>" class="GenericTextHyperlink2">View  ?Action=MyRanch&SubAction=Remove&ID=<%=rs("TPRID")%>" class="GenericTextHyperlink2">Remove  

<% End Sub Sub TPRequestSignIn( ByRef trc ) If Not MemberSignedIn( trc ) Then %>

To place an ad, please sign-in or become a member.

<% End If Call WhiteSpacer( 12 ) Call SignInForm( trc ) End Sub Sub TPViewAdCounts( ByRef trc ) Dim rs, totads, tothits Set rs = trc.Execute("SELECT COUNT(*) AS CNT FROM TradingPostAds WHERE TPAdStatus IN ('M','A') ") totads = rs("CNT") rs.Close Set rs = trc.Execute("SELECT SUM(TPHits) AS HITS FROM TradingPostAds WHERE TPAdStatus IN ('M','A') ") tothits = rs("HITS") rs.Close %>

There are currently <%=totads%> ads in the Trading Arena which have been viewed <%=tothits%> times.
<% End Sub Sub TPSearchCriteria Dim rs Set rs = trc.Execute("SELECT * FROM TradingPostCategories ORDER BY TCOrder") %>

Order of Ads:  

>Pictures Only  

Category :  

<% Response.Write( DatabaseSelectList( trc, "TPCategory", Session("TPCategory"), "TradingPostCategories", _ "TCCode", "TCText", "TCOrder" )) %>  

Search Words :  

">

 

<% rs.Close End Sub Function TPValidSearchData() TPValidSearchData = True Session("TPOrderBy") = "TPPictureUpgrade DESC" Session("TPSellOrWant") = CleanInput(Request.Form("TPSellOrWant")) Session("TPCategory") = CleanInput(Request.Form("TPCategory")) Session("TPSearchWords") = CleanInput(LCase(Trim(Request.Form("TPSearchWords")))) Session("TPPicturesOnly") = CleanInput(Request.Form("TPPicturesOnly")) If Len(Session("TPSellOrWant"))=0 Then Session("TPSellOrWant") = "E" End Function Function TPSearchSQL() Dim sql, wcnt, i, words, andor sql = Empty TPSearchSQL = Empty If Session("TPSellOrWant") <> "E" And Len(Session("TPSellOrWant")) > 0 Then sql = sql & "TPSellOrWant = '" & Session("TPSellOrWant") & "' AND " End If If Session("TPCategory") <> "999" And Session("TPCategory") <> "0" And Len(Session("TPCategory")) > 0 Then sql = sql & "TPCategoryID = " & Session("TPCategory") & " AND " End If wcnt = GetSearchWords( Session("TPSearchWords"), " ", words, andor ) If wcnt > 0 Then For i = 0 To wcnt - 1 sql = sql & "( Lower(TPDescription) LIKE '%" & words(i) & "%' OR " & _ " Lower(TPTitle) LIKE '%" & words(i) & "%' OR " & _ " Lower(TPContactName) LIKE '%" & words(i) & "%' OR " & _ " Lower(TPAdNumber) LIKE '" & words(i) & "' ) " & andor & " " Next End If If IsEmpty( sql ) Then sql = "SELECT * FROM TRADINGPOSTADS WHERE TPADPAID = 'P' AND TPADSTATUS IN ('A','M') " Else sql = "SELECT * FROM TRADINGPOSTADS WHERE TPADPAID = 'P' AND TPADSTATUS IN ('A','M') AND " & sql sql = Mid(sql, 1, Len(sql) - 4 ) End If If Session("TPPicturesOnly") = "Y" Then sql = sql & " AND TPPictureURL IS NOT NULL " Session("TPOrderBy") = "TPPictureUpgrade DESC" Else If len(Session("TPOrderBy")) = 0 Then Session("TPOrderBy") = "TPDatePlaced DESC" End If TPSearchSQL = sql End Function Function TPItemListSQL(ByRef trc, id) sql = "" If len(id) > 0 Then Set rs = trc.execute("SELECT TPMID FROM TradingPostAds WHERE (TPID = '"&id&"') AND (TPAdStatus <> 'D')") If NOT rs.EOF Then sql = "SELECT * FROM TradingPostAds WHERE (TPMID = "&rs("TPMID")&" AND (TPAdStatus <> 'D') AND TPID <> "&Request("ID")&")" End If End If TPItemListSQL = sql End Function Sub TRShowAdUpgrades( ByRef trc, tpid ) Dim rs, pu, lu pu = "N" lu = "NoUpgrade" If ValidID( tpid ) Then Set rs = trc.Execute("SELECT TPLocationUpgrade, TPPictureUpgrade FROM TradingPostAds WHERE TPID=" & tpid ) If Not rs.EOF Then pu = rs("TPPictureUpgrade") lu = rs("TPLocationUpgrade") End If rs.Close End If %>

Please select advertising upgrades:

a
Searchable ad
(FREE)
b
Searchable ad with photo

c
Home page feature
 (text only)
d
Home page feature with photo

> Free!

  • Searchable ad (No Photo) (a)
> $15.00
  • Searchable ad (a)
  • TeamRoper.com's home page feature ad (text only) (c)
> $25.00
  • Searchable ad with photo (b)
  • TeamRoper.com's home page feature ad with photo (d)
    $5.00 > Add photo to searchable ads. Upload directly from your computer. (b)

Promo code

<% End Sub Sub TRStoreAdUpgrades( ByRef trc, tpid ) If Not ValidID( tpid ) Then Exit Sub If Len(Session("TPPictureUpgrade")) = 0 Then Session("TPPictureUpgrade") = "N" If Len(Session("TPLocationUpgrade")) = 0 Then Session("TPLocationUpgrade") = "NoUpgrade" trc.Execute( "UPDATE TradingPostAds " & _ "SET TPLocationUpgrade='" & Session("TPLocationUpgrade") & "', " & _ " TPPictureUpgrade='" & Session("TPPictureUpgrade") & "' " & _ "WHERE TPID = " & tpid ) End Sub Function AllowAdUpgrades( ByRef trc, tpid ) ''' ' This function checks to see if the customer is allowed to upgrad his advertisement. Ad upgrades include ' adding a picture or presenting the advertisement on the home page. Once a customer has paid for an ad ' upgrade, he is not allowed to change the upgrade. This is because it would get too involved with charging ' for the difference or refunding. That is handled manually though the SiteManager. ''' Dim rs AllowAdUpgrades = False If Len(tpid)=0 Or IsNull(tpid) Then Exit Function Set rs = trc.Execute("SELECT TPPictureUpgrade, TPLocationUpgrade FROM TradingPostAds WHERE TPID = " & tpid ) If rs.EOF Then Exit Function If rs("TPPictureUpgrade") = "N" And rs("TPLocationUpgrade") = "NoUpgrade" Then AllowAdUpgrades = True ''' ' Check to see if payment was successful. If not sucessful then reset to "N" and "NoUpgrade" ' respectively. If sucessful then flag AllowAdUpgrades as TRUE. ''' If PaymentReceived( trc, "TRADINGARENA", tpid ) Then AllowAdUpgrades = False Else AllowAdUpgrades = True End If rs.Close End Function Function TPValidEnhancement(ByRef trc, tpid, item ) ''' ' item is the coloumn that is being checked ' This function checks for selected enhancements. ''' Dim rs, sql TPValidEnhancement = false sql ="SELECT TPENewsletter, TPAdditionalPhoto, TPItemLists, TPMemberMatcher FROM TradingPostAds WHERE TPID = " & tpid Set rs = trc.Execute(sql) If rs.EOF Then Exit Function Select Case item Case "ENewsletter" If rs("TPENewsletter") = "Y" Then TPValidEnHancement = True End If Case "AdditionalPhoto" If rs("TPAdditinoalPhoto") = "Y" Then TPValidEnhancement = True End If Case "DisplayAllAds" If rs("TPItemLists") = "Y" Then TPValidEnhancement = True End If Case "MemberMatcher" If rs("TPMemberMatcher") = "Y" Then TPValidEnhancement = True End If Case Else End Select rs.Close End Function Function TRValidAdUpgrades() Session("TPPictureUpgrade") = CleanInput(Request.Form("TPPictureUpgrade")) Session("TPLocationUpgrade") = CleanInput(Request.Form("TPLocationUpgrade")) If Len(Session("TPPictureUpgrade")) = 0 Then Session("TPPictureUpgrade") = "N" If Len(Session("TPLocationUpgrade")) = 0 Then Session("TPLocationUpgrade") = "NoUpgrade" If Session("TPLocationUpgrade") = "HomePagePicture" Then Session("TPPictureUpgrade") = "Y" If Session("TPPictureUpgrade") = "N" And Session("TPLocationUpgrade") = "NoUpgrade" Then TRValidAdUpgrades = False Else TRValidAdUpgrades = True End If End Function Function TRGetPayment( ByRef trc, tpid ) ''' ' Determines the ad upgrade charges and sets up for the call to the CC payment system if necessary. ' Creates a payment record in the payment table. ' If no payment is needed then GetPaymentID returns a zero. ''' Dim total, rs TRGetPayment = CDbl(0.00) If Not ValidID(tpid) Then Exit Function Set rs = trc.Execute("SELECT TPENewsletter, TPLocationUpgrade, TPPictureUpgrade FROM TradingPostAds WHERE TPID=" & tpid ) If rs.EOF Then Exit Function total = CDbl(0.00) Select Case rs("TPLocationUpgrade") Case "HomePageText" total = total + CDbl( 15.00 ) Case "HomePagePicture" ''' ' cost of upgrade is $24 but adds the $5.00 picture upgrade below for total=$29.00 ''' total = total + CDbl( 20.00 ) Case Else ''' ' base ad ''' total = total + CDbl( 4.99 ) End Select If rs("TPPictureUpgrade") = "Y" Then total = total + CDbl( 5.00 ) rs.Close TRGetPayment = CDbl(total) End Function Function TRGetAdPayment( ByRef trc, tpid ) ''' ' Determines the ad upgrade charges and sets up for the call to the CC payment system if necessary. ' Creates a payment record in the payment table. ' If no payment is needed then GetPaymentID returns a zero. ''' Dim total, rs TRGetAdPayment = CDbl(0.00) If Not ValidID(tpid) Then Exit Function Set rs = trc.Execute("SELECT TPENewsletter, TPPictureUpgrade, TPLocationUpgrade, TPAdditionalPhoto, " & _ " TPMemberMatcher, TPAdType, TPDurationID " & _ " FROM TradingPostAds Where TPID=" & tpid ) If rs.EOF Then Exit Function total = CDbl(0.00) Select Case rs("TPAdType") Case "1" total = total + CDbl( 4.99 ) Case "2" total = total + CDbl( 9.99 ) Case "3" total = total + CDbl( 14.99 ) Case "4" total = total + CDbl(24.99) Case Else total = total + CDbl( 4.99 ) End Select Select Case rs("TPDurationID") Case "7" total = total + CDbl( 5.00 ) Case "14" total = total + CDbl( 10.00 ) Case "21" total = total + CDbl( 15.00 ) Case Else total = total + CDbl( 0.00 ) End Select Select Case rs("TPLocationUpgrade") Case "HomePageText" 'total = total + CDbl( 15.00 ) Case "HomePagePicture" ''' ' cost of upgrade is $24 but adds the $5.00 picture upgrade below for total=$29.00 ''' 'total = total + CDbl( 20.00 ) Case Else ''' ' free ad ''' total = total + CDbl( 0.00 ) End Select If rs("TPENewsletter") = "Y" Then total = total + CDbl(24.99) If rs("TPAdditionalPhoto") = "Y" Then total = total + CDbl( 5.00 ) If rs("TPMemberMatcher") = "Y" Then total = total + CDbl( 9.99 ) rs.Close TRGetAdPayment = CDbl(total) End Function Function SetUploaderSessionVariables( tpid ) Dim rs SetUploaderSessionVariables = True If Len(tpid) = 0 Or IsNull(tpid) Or IsEmpty(tpid) Then SetUploaderSessionVariables = False Exit Function End If Set rs = trc.Execute("SELECT * FROM TradingPostAds WHERE TPID = " & tpid ) If rs.EOF Then SetUploaderSessionVariables = False Exit Function End If Session("ULInstructions") = "Please upload the picture file associated with your Trading Arena ad. " & _ "The file size of your picture should not exceed 120KB in size. Files larger than 120KB " & _ "will take too long to download and view. Your picture will " & _ "appear in 1 to 2 days upon content approval by TeamRoper.com." ' removed "You can upload a picture up to 10 times; however, only the last picture uploaded will be viewed with your advertisement. " Session("ULMaxBytes") = 120000 ' allow a maximum of 60K bytes in any one file Session("ULValidContent") = "IMAGE" ' allow only *.gif and *.jpg files Session("ULFileNamePrefix") = "TP" ' allow any filename prefix If TPGetMaxPictureUpload(trc, tpid) = 0 then Session("ULMaxUploads") = 10 ' maximum of 51 files uploaded Else Session("ULMaxUploads") = TPGetMaxPictureUpload(trc, tpid) End If Session("ULCategory") = "TRADINGARENA" ' the category of the images - education Session("ULCategoryID") = tpid ' the category / record ID Session("ULDestPath") = "/Trading/Images/" ' the destination folder for the image files Session("ULReturnURL") = "/Trading/SearchView.asp" rs.Close End Function Sub ClearSessionVariables Session("TPSellOrWant") = Empty Session("TPCategory") = Empty Session("TPSearchWord1") = Empty Session("TPSearchWord2") = Empty Session("TPSearchPage") = Empty Session("TPViewPage") = Empty Session("TPOrderBy") = Empty Session("TPPicturesOnly") = Empty Session("TPChild") = Empty Session("TPCParent1") = Empty Session("TPCParent2") = Empty Session("TPPParent11") = Empty Session("TPPParent12") = Empty Session("TPPParent21") = Empty Session("TPPParent22") = Empty Session("TPGPParent3111") = Empty Session("TPGPParent3211") = Empty Session("TPGPParent3112") = Empty Session("TPGPParent3212") = Empty Session("TPGPParent3121") = Empty Session("TPGPParent3221") = Empty Session("TPGPParent3122") = Empty Session("TPGPParent3222") = Empty End Sub Function TradingImageURL( ByRef trc, tpid ) ''' ' Obtains the image URL of an image associated with a Trading Arena ad. Please note ' this routine is somewhat duplicated in the "AdHandling.asp" include file. Changes ' here should be considered in the routine in AdHandling.asp ''' Dim rs, imgurl(10), imgfile(10), j, i, fs, imgwidth, imgheight, imgdepth, imagetype, dflag TradingImageURL = Empty If Not ValidID( tpid ) Then Exit Function Set rs = trc.Execute("SELECT TPAdNumber, TPPictureURL, TPID FROM TradingPostAds WHERE TPID= " & tpid ) If rs.EOF Then Exit Function ''' ' The TPAdNumber routine is the OLD way of doing images. In the new TeamRoper ' the TPPictureURL is used instead. ''' If Not IsNull( rs("TPAdNumber") ) Then ''' ' Check to see if the image file exists. If it does then allow display of the image. ' imgurl = the local relative URL of the image file ' imgfile = the hard drive file name of the image file ''' imgurl(3) = "/Trading/Images/" & CStr(rs("TPAdNumber")) & ".gif" imgfile(3) = Server.MapPath( imgurl(3) ) imgurl(2) = "/Trading/Images/" & CStr(rs("TPAdNumber")) & ".jpg" imgfile(2) = Server.MapPath( imgurl(2) ) Else imgurl(3) = Empty imgfile(3) = Empty imgurl(2) = Empty imgfile(2) = Empty End If If Not IsNull( rs("TPPictureURL") ) Then imgurl(1) = CStr( rs("TPPictureURL") ) imgfile(1) = Server.MapPath( imgurl(1) ) Else imgurl(1) = Empty imgfile(1) = Empty End If Set fs = Server.CreateObject("Scripting.FileSystemObject") For j = 1 to 3 If fs.FileExists( imgfile(j) ) Then TradingImageURL = imgurl(j) Next rs.Close End Function Function MultipleTradingImageUrl( ByRef trc, tpid ) Dim cnt, rs, PathString If Not ValidID( tpid ) Then Exit Function MultipleTradingImageUrl = Empty cnt = 1 Set rs = trc.Execute("SELECT ULDestPath, ULDestFileName FROM Uploads WHERE ULCategoryID ="& tpid ) Do While NOT rs.EOF PathString = PathString & rs("ULDestPath") & rs("ULDestFileName") & ";" cnt = cnt + 1 rs.MoveNext Loop MultipleTradingImageUrl = PathString End Function Function TradingImageHTML( imgurl ) Dim imgwidth, imgheight, imgdepth, imgtype, ratio ''' ' Now check to see if the graphics file is too wide and if so then ' specify an HTML height and width which will resize appropriately. ' Max width is 520 ''' TradingImageHTML = Empty If Len(imgurl) = 0 Or IsNull(imgurl) Then Exit Function imgwidth = Emtpy imgheight = Empty If gfxSpex( Server.MapPath(imgurl), imgwidth, imgheight, imgdepth, imgtype ) Then If CInt(imgwidth) > 520 Then ratio = CSng(CSng(520) / CSng(imgwidth)) imgheight = CInt(CSng(imgheight) * ratio ) imgwidth = CInt(CSng(imgwidth) * ratio ) End If If CInt(imgheight) > 500 Then ratio = CSng(CSng(500) / CSng(imgheight)) imgwidth = CInt(CSng(imgwidth) * ratio ) imgheight = CInt(CSng(imgheight) * ratio ) End If imgwidth = " width=""" & CStr(imgwidth) & """ " imgheight = " height=""" & CStr(imgheight) & """ " TradingImageHTML = "" Else TradingImageHTML = "" End If End Function Function TPAllowUpload( ByRef trc, tpid ) ''' ' Check to see if the specified upgrade is valid and paid for. ''' Dim rs TPAllowUpload = False If Not ValidID(tpid) Then Exit Function Set rs = trc.Execute("SELECT TPPictureUpgrade FROM TradingPostAds WHERE TPID=" & tpid ) If rs.EOF Then Exit Function If rs("TPPictureUpgrade") = "Y" Then If PaymentReceived( trc, "TRADINGARENA", tpid ) Then TPAllowUpload = True End If End If rs.Close End Function Function TPTitleSize( title ) If Len( title ) < 20 Then TPTitleSize = 7 ElseIf Len( title ) >= 21 And Len( title ) < 30 Then TPTitleSize = 6 ElseIf Len( title ) >= 31 And Len( title ) <= 40 Then TPTitleSize = 5 ElseIf Len(title) > 40 Then TPTitleSize = 4 End If End Function Sub TPClearSearchSessionVariables Session("TPSellOrWant") = Empty Session("TPCategory") = Empty Session("TPSearchWord1") = Empty Session("TPSearchWord2") = Empty Session("TPPlacedSince") = Empty Session("TPSearchAdsPage") = Empty Session("TPMemberAdsPage") = Empty Session("TPOrderBy") = Empty Session("TPPicturesOnly") = Empty Session("TPChild") = Empty Session("TPCParent1") = Empty Session("TPCParent2") = Empty Session("TPPParent11") = Empty Session("TPPParent12") = Empty Session("TPPParent21") = Empty Session("TPPParent22") = Empty Session("TPGPParent3111") = Empty Session("TPGPParent3211") = Empty Session("TPGPParent3112") = Empty Session("TPGPParent3212") = Empty Session("TPGPParent3121") = Empty Session("TPGPParent3221") = Empty Session("TPGPParent3122") = Empty Session("TPGPParent3222") = Empty End Sub Sub TPClearSavedSessVars Session("TPAdNumber") = Empty Session("TPTitle") = Empty Session("TPPrice") = Empty Session("TPDescription") = Empty Session("TPAdditionalPhoto") = Empty Session("TPItemLists") = Empty Session("TPMemberMatcher") = Empty Session("TPDurationID") = Empty Session("TPAdType") = Empty Session("TPENewsletter") = Empty Session("TPEdit") = Empty Session("TPChild") = Empty Session("TPCParent1") = Empty Session("TPCParent2") = Empty Session("TPPParent11") = Empty Session("TPPParent12") = Empty Session("TPPParent21") = Empty Session("TPPParent22") = Empty Session("TPGPParent3111") = Empty Session("TPGPParent3211") = Empty Session("TPGPParent3112") = Empty Session("TPGPParent3212") = Empty Session("TPGPParent3121") = Empty Session("TPGPParent3221") = Empty Session("TPGPParent3122") = Empty Session("TPGPParent3222") = Empty End Sub Sub TPClearAdvertiseSessionVariables Session("TPAdNumber") = Empty Session("TPExpireEMail") = Empty Session("TPDuration") = Empty Session("TPTitle") = Empty Session("TPContactName") = Empty Session("TPContactPhone") = Empty Session("TPEMail") = Empty Session("TPWeb") = Empty Session("TPPrice") = Empty Session("TPState") = Empty Session("TPStateRegion") = Empty Session("TPCity") = Empty Session("TPDescription") = Empty Session("TPCategoryID") = Empty Session("TPSellOrWant") = Empty Session("TPDescription") = Empty Session("TPAdExpires") = Empty Session("TPAdditionalPhoto") = Empty Session("TPItemLists") = Empty Session("TPMemberMatcher") = Empty Session("TPDurationID") = Empty Session("TPAdType") = Empty Session("PMCode") = Empty Session("TPENewsletter") = Empty Session("TPObject") = Empty Session("TPChild") = Empty Session("TPCParent1") = Empty Session("TPCParent2") = Empty Session("TPPParent11") = Empty Session("TPPParent12") = Empty Session("TPPParent21") = Empty Session("TPPParent22") = Empty Session("TPGPParent3111") = Empty Session("TPGPParent3211") = Empty Session("TPGPParent3112") = Empty Session("TPGPParent3212") = Empty Session("TPGPParent3121") = Empty Session("TPGPParent3221") = Empty Session("TPGPParent3122") = Empty Session("TPGPParent3222") = Empty End Sub Function TPGetCategorySelectList( listname, seltext ) ''' ' This function creates an HTML " & vbCrLf If IsEmpty(seltext) Or IsNull(seltext) Then seltext = "0" Do While Not rs.EOF If CStr(seltext) = CStr(rs("TCCode")) Then s = s & "" & vbCrLf Else s = s & "" & vbCrLf End If rs.MoveNext Loop s = s & "" & vbCrLf TPGetCategorySelectList= s rs.MoveFirst End If End Function Function TPGetDurationSelectList( listname, seltext ) ''' ' This function creates an HTML " & vbCrLf If IsEmpty(seltext) Or IsNull(seltext) Then seltext = "0" Do While Not rs.EOF If CStr(seltext) = CStr(rs("TDCode")) Then s = s & "" & vbCrLf Else s = s & "" & vbCrLf End If rs.MoveNext Loop s = s & "" & vbCrLf TPGetDurationSelectList = s rs.MoveFirst End If End Function Function TPGetMaxPictureUpload( ByRef trc, tpid ) Dim rs, mup mup = 0 Set rs = trc.Execute("SELECT TPAdditionalPhoto, TPAdType FROM TradingPostAds WHERE TPID = "& tpid ) If NOT rs.EOF Then If rs("TPAdType") > 1 Then 'what add type did they buy mup = mup + 1 End If If rs("TPAdditionalPhoto") = "Y" Then 'did they buy an additional photo mup = mup + 1 End If Else If Session("TPAdType") > 1 Then 'what add type did they buy mup = mup + 1 End If If Session("TPAdditionalPhoto") = "Y" Then 'did they buy an additional photo mup = mup + 1 End If End If TPGetMaxPictureUpload = mup End Function Sub DeletePictureUpload( ByRef trc, tpid, mmid ) If ValidID(tpid) Then trc.execute("DELETE Uploads WHERE ULMID = '"& mmid &"' AND ULCATEGORYID ='"&tpid&"'" ) End If End Sub Function SAGetSearchSQL(trc, mmid, tpsaid) Dim sql, wcnt, i, words, andor sql = Empty SAValidSearchData= False If Len(CleanInput(Request.Form("TPSADescription"))) > 0 Then Session("TPSADescription") = CleanInput(LCase(Trim(Request.Form("TPSADescription")))) Else Set rs = trc.Execute("SELECT * FROM TradingPostSearchAgents WHERE tpsaid =" & tpsaid & " AND tpsamid="& mmid) If NOT rs.EOF Then Session("TPSADescription") = LCase(Trim(rs("TPSADescription"))) End If End If wcnt = GetSearchWords( Session("TPSADescription"), " ", words, andor ) If wcnt > 0 Then For i = 0 To wcnt - 1 sql = sql & " Lower(TPDescription) LIKE '%" & words(i) & "%' "& andor & " " Next End If If IsEmpty( sql ) Then sql = "SELECT * FROM TradingPostAds WHERE TPAdStatus IN ('A','M') " Else sql = "SELECT * FROM TradingPostAds WHERE TPAdStatus IN ('A','M') AND " & sql sql = Mid(sql, 1, Len(sql) - 4 ) End If sql = sql & " AND TPMemberMatcher = 'Y' " SAGetSearchSQL = sql End Function Function ValidAdItemList(ByRef trc, mmid) ValidAdItemList = false Set rs = trc.execute("Select * from dbo.MemberEnhancements Where MEMID="& mmid) If NOT rs.EOF Then If rs("MEItemListEndDate") >= date() Then ValidAdItemList = true End If End If rs.Close End Function %> <% 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 %> <% Function MoveFile( fromfile, tofile ) Dim fs, tpath, fpath If right(trim(ucase(tofile)), 10) <> right(trim(ucase(fromfile)), 10) Then Call DeleteFile( tofile ) End If 'On Error Resume Next tpath = VirtualToPhysicalPath(tofile) fpath = VirtualToPhysicalPath(fromfile) 'response.Write(fromfile &" TO "& tofile &"
") Set fs = CreateObject("Scripting.FileSystemObject") If trim(ucase(tpath)) <> trim(ucase(fpath)) Then fs.MoveFile VirtualToPhysicalPath( fpath ) , VirtualToPhysicalPath( tpath ) 'response.Write(VirtualToPhysicalPath( fpath ) &" TO "& VirtualToPhysicalPath( tpath ) ) 'response.Write("here") End If If fs.FileExists( VirtualToPhysicalPath(tofile) ) Then MoveFile = True Else MoveFile = False Call AddMessageError( "File could not be moved. " & _ "FromVirt='" & fromfile & "' ToVirt='" & tofile & "' " & _ "FromPhys='" & VirtualToPhysicalPath( fromfile ) & "' " & _ "ToPhys='" & VirtualToPhysicalPath( tofile ) & "'" ) If InStr( LCase(tpath), "rejectfiles" ) <> 0 Then MoveFile = True If InStr( LCase(tpath), "deletedfiles" ) <> 0 Then MoveFile = True End If On Error Goto 0 End Function Function CopyFile( fromfile, tofile ) Dim fs Call DeleteFile( tofile ) On Error Resume Next Set fs = CreateObject("Scripting.FileSystemObject") fs.CopyFile VirtualToPhysicalPath( fromfile ) , VirtualToPhysicalPath( tofile ) If fs.FileExists( VirtualToPhysicalPath(tofile) ) Then CopyFile = True Else CopyFile = False Call AddMessageError( "File could not be copied. " & _ "FromVirt='" & fromfile & "' ToVirt='" & tofile & "' " & _ "FromPhys='" & VirtualToPhysicalPath( fromfile ) & "' " & _ "ToPhys='" & VirtualToPhysicalPath( tofile ) & "'" ) End If On Error Goto 0 End Function Function FileExists( filename ) Dim fs FileExists = False Set fs = CreateObject("Scripting.FileSystemObject") If fs.FileExists( VirtualToPhysicalPath( filename ) ) Then FileExists = True End Function Sub DeleteFile( filename ) Dim fs On Error Resume Next Set fs = CreateObject("Scripting.FileSystemObject") fs.DeleteFile VirtualToPhysicalPath( filename ) , True On Error Goto 0 End Sub Sub CreateFolder( vpath ) Dim fs, fld Set fs = CreateObject("Scripting.FileSystemObject") Set fld = fs.CreateFolder( VirtualToPhysicalPath( vpath ) ) End Sub Sub DeleteFolder( vpath ) Dim fs On Error Resume Next Set fs = CreateObject("Scripting.FileSystemObject") fs.DeleteFolder VirtualToPhysicalPath( vpath ) , True On Error Goto 0 End Sub Function VirtualToPhysicalPath( vpath ) Dim vp ''' ' If there's a : in the file name then it's already a physical path. ''' If Instr(vpath, ":") <> 0 Then VirtualToPhysicalPath = vpath Exit Function End If vp = Trim(vpath) vp = Replace( vp, "/", "\" ) vp = Replace( vp, "\\", "\" ) ''' ' remove the "\" from the virtual paths ''' If Right( vp, 1 ) = "\" Then vp = Mid( vp, 1, Len(vp) -1 ) If Left(vp, 1) = "\" Then vp = Mid( vp, 2 ) vp = Request.ServerVariables("APPL_PHYSICAL_PATH") & vp VirtualToPhysicalPath = vp End Function Function CombinePathFilename( vpath, vfilename ) ''' ' concatenates the path and the filename to properly form a URL ''' Dim s s = LCase(Trim(vpath)) s = Replace( s, "\", "/" ) s = Replace( s, "//", "/" ) If Right(s,1) = "/" Then s = s & LCase(Trim(vfilename)) Else s = s & "/" & LCase(Trim(vfilename)) End If CombinePathFilename = s End Function Function UploadCount( ByRef trc, mid, category, status ) ''' ' Counts the number of uploads registered in the upload table for a specific user (mid) ' and a specific type of upload. Dim rs UploadCount = 0 Set rs = trc.Execute( "SELECT COUNT(*) AS CNT FROM Uploads WHERE ULMID = " & mid & " AND " & _ "ULCategory = '" & category & "' AND ULStatus = '" & status & "'" ) If Not rs.EOF Then UploadCount = CLng( rs("CNT") ) rs.Close End Function Function UploadRecordCount(ByRef trc, mid, category, categoryid) ''' ' Counts the number of uploads registered in the upload table for a specific user (mid) ' and ULCategoryID ''' Dim rs If len(categoryid) = 0 Then Exit Function UploadRecordCount = 0 Set rs = trc.Execute( "SELECT COUNT(*) AS CNT FROM Uploads WHERE ULMID = " & mid & " AND " & _ " ULCategory = '" & category & "' AND ULCategoryID = " & categoryid ) If Not rs.EOF Then UploadRecordCount= CLng( rs("CNT") ) rs.Close End Function Sub MoveUploadedFilesByCategory( ByRef trc, category, categoryID, mvfrom, mvto ) ''' ' There are 3 valid file move scenarios: ' (1) A "NEW" or "PLACED" file is being deleted: mvto = "DELETED" ' (2) A file is being moved from "NEW" to "PLACED": mvfrom="NEW", mvto="PLACED" ' (3) A file is being moved from "NEW" to "REJECT": mvfrom="NEW", mvto="REJECT" ' ''' Dim DeletedFolder, RejectFolder, rs, sql, mv, action DeletedFolder = "Uploads/DeletedFiles" RejectFolder = "Uploads/RejectFiles" mv = UCase( Trim(mvfrom) & Trim(mvto) ) If mv = "DELETEDPLACED" Then action = 4 Else If Instr( mv, "DELETED" ) <> 0 Then action = 1 Else If mv = "NEWPLACED" Then action = 2 Else If mv = "NEWREJECT" Then action = 3 End If End If End If End If Select Case action Case 1 ''' ' move the file(s) to the deleted directory sql = "SELECT * FROM Uploads WHERE ULCategory='" & category & "' AND " & _ "ULCategoryID=" & categoryID & " AND " & _ "(ULStatus='PLACED' OR ULStatus='NEW')" Set rs = Server.CreateObject("ADODB.RecordSet") rs.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText Do While Not rs.EOF ''' ' If a file with the same name already exists in the DeletedFolder then remove it. ''' If Len(rs("ULDestFileName")) > 0 Then _ Call DeleteFile( DeletedFolder & "/" & rs("ULDestFileName") ) Select Case rs("ULStatus") Case "PLACED" If MoveFile( rs("ULDestPath") & "/" & rs("ULDestFileName"), DeletedFolder & "/" & rs("ULDestFileName") ) Then rs("ULStatus") = "DELETED" rs.Update End If Case "NEW" If MoveFile( rs("ULNewPath") & "/" & rs("ULNewFileName"), DeletedFolder & "/" & rs("ULNewFileName") ) Then rs("ULStatus") = "DELETED" rs.Update End If Case Else End Select rs.MoveNext Loop rs.Close Case 2 ''' ' File is being moved from "NEW" to "PLACED" sql = "SELECT * FROM Uploads WHERE ULCategory='" & category & "' AND " & _ "ULCategoryID=" & categoryID & " AND ULStatus='NEW')" Set rs = Server.CreateObject("ADODB.RecordSet") rs.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText Do While Not rs.EOF ''' ' The destination for a new file is: rs("ULDestPath") / rs("ULDestFileName") ' If a file with the same name already exists in the destination folder then remove it. ''' 'If Len(rs("ULDestFileName")) > 0 Then _ ' Call DeleteFile( rs("ULDestPath") & "/" & rs("ULDestFileName") ) If Len(rs("ULDestFileName")) > 0 Then If VirtualToPhysicalPath(rs("ULNewPath") & "\" & rs("ULNewFileName")) <> VirtualToPhysicalPath(rs("ULDestPath") & "\" & rs("ULDestFileName")) Then Call DeleteFile( rs("ULDestPath") & "/" & rs("ULDestFileName") ) End If End If If MoveFile( rs("ULNewPath") & "/" & rs("ULNewFileName"), rs("ULDestPath") & "/" & rs("ULDestFileName") ) Then rs("ULStatus") = "PLACED" rs.Update End If rs.MoveNext Loop rs.Close Case 3 ''' ' File is being moved from "NEW" to "REJECT" sql = "SELECT * FROM Uploads WHERE ULCategory='" & category & "' AND " & _ "ULCategoryID=" & categoryID & " AND ULStatus='NEW')" Set rs = Server.CreateObject("ADODB.RecordSet") rs.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText Do While Not rs.EOF ''' ' The destination for a new file is: rs("ULDestPath") / rs("ULDestFileName") ' If a file with the same name already exists in the destination folder then remove it. ''' If Len(rs("ULDestFileName")) > 0 Then _ Call DeleteFile( rs("ULDestPath") & "/" & rs("ULDestFileName") ) If MoveFile( rs("ULNewPath") & "/" & rs("ULNewFileName"), RejectFolder & "/" & rs("ULDestFileName") ) Then rs("ULStatus") = "REJECT" rs.Update End If rs.MoveNext Loop rs.Close Case 4 ''' ' move the file(s) from deleted to placed directory sql = "SELECT * FROM Uploads WHERE ULCategory='" & category & "' AND " & _ "ULCategoryID=" & categoryID & " AND ULStatus='DELETED' " Set rs = Server.CreateObject("ADODB.RecordSet") rs.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText Do While Not rs.EOF If MoveFile( DeletedFolder & "/" & rs("ULDestFileName"), rs("ULDestPath") & "/" & rs("ULDestFileName") ) Then rs("ULStatus") = "PLACED" rs.Update End If rs.MoveNext Loop rs.Close Case Else End Select End Sub Sub MoveUploadedFilesUploadID( ByRef trc, ULID, mvfrom, mvto ) ''' ' There are 3 valid file move scenarios: ' (1) A "NEW" or "PLACED" file is being deleted: mvto = "DELETED" ' (2) A file is being moved from "NEW" to "PLACED": mvfrom="NEW", mvto="PLACED" ' (3) A file is being moved from "NEW" to "REJECT": mvfrom="NEW", mvto="REJECT" ' ''' Dim DeletedFolder, RejectFolder, rs, sql, mv, action, p1, p2 DeletedFolder = "Uploads/DeletedFiles" RejectFolder = "Uploads/RejectFiles" If Len(ULID)=0 Or IsEmpty(ULID) Or IsNull(ULID) Then Exit Sub mv = UCase( Trim(mvfrom) & Trim(mvto) ) If Instr( mv, "DELETED" ) <> 0 Then action = 1 Else If mv = "NEWPLACED" Then action = 2 Else If mv = "NEWREJECT" Then action = 3 End If End If End If Select Case action Case 1 ''' ' move the file(s) to the deleted directory sql = "SELECT * FROM Uploads WHERE ULID = " & ULID & " AND ULStatus='NEW' " Set rs = Server.CreateObject("ADODB.RecordSet") rs.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText Do While Not rs.EOF ''' ' If a file with the same name already exists in the DeletedFolder then remove it. ''' If Len(rs("ULDestFileName")) > 0 Then _ Call DeleteFile( DeletedFolder & "/" & rs("ULDestFileName") ) Select Case rs("ULStatus") Case "PLACED" If MoveFile( rs("ULDestPath") & "/" & rs("ULDestFileName"), DeletedFolder & "/" & rs("ULDestFileName") ) Then rs("ULStatus") = "DELETED" rs.Update End If Case "NEW" If MoveFile( rs("ULNewPath") & "/" & rs("ULNewFileName"), DeletedFolder & "/" & rs("ULNewFileName") ) Then rs("ULStatus") = "DELETED" rs.Update End If Case Else End Select rs.MoveNext Loop rs.Close Case 2 ''' ' File is being moved from "NEW" to "PLACED" sql = "SELECT * FROM Uploads WHERE ULID = " & ULID & " AND ULStatus='NEW' " Set rs = Server.CreateObject("ADODB.RecordSet") rs.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText Do While Not rs.EOF ''' ' The destination for a new file is: rs("ULDestPath") / rs("ULDestFileName") ' If a file with the same name already exists in the destination folder then remove it. ''' If Len(rs("ULDestFileName")) > 0 Then If VirtualToPhysicalPath(rs("ULNewPath") & "\" & rs("ULNewFileName")) <> VirtualToPhysicalPath(rs("ULDestPath") & "\" & rs("ULDestFileName")) Then Call DeleteFile( rs("ULDestPath") & "/" & rs("ULDestFileName") ) End If End If If MoveFile( rs("ULNewPath") & "\" & rs("ULNewFileName"), rs("ULDestPath") & "/" & rs("ULDestFileName") ) Then rs("ULStatus") = "PLACED" rs.Update End If rs.MoveNext Loop rs.Close Case 3 ''' ' File is being moved from "NEW" to "REJECT" sql = "SELECT * FROM Uploads WHERE ULID = " & ULID & " AND ULStatus='NEW' " Set rs = Server.CreateObject("ADODB.RecordSet") rs.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText Do While Not rs.EOF ''' ' The destination for a new file is: rs("ULDestPath") / rs("ULDestFileName") ' If a file with the same name already exists in the destination folder then remove it. ''' If Len(rs("ULDestFileName")) > 0 Then _ Call DeleteFile( rs("ULDestPath") & "/" & rs("ULDestFileName") ) If MoveFile( rs("ULNewPath") & "/" & rs("ULNewFileName"), RejectFolder & "/" & rs("ULDestFileName") ) Then rs("ULStatus") = "REJECT" rs.Update End If rs.MoveNext Loop rs.Close Case Else End Select End Sub Sub UpdateImageLinks( ByRef trc, ulid ) ''' ' This routine updates image links and database fields so that they correctly point ' to the uploaded image file. ''' Dim rs, rsh, sql, s If Not ValidID(ulid) Then Exit Sub Set rs = trc.Execute("SELECT * FROM Uploads WHERE ULStatus='PLACED' AND ULID=" & ulid ) If rs.EOF Then Exit Sub ''' ' The category and record id are recorded in the Upload record. Get the HTML from the ' corresponding field and replace the image links. ''' ' response.Write(rs("ULCategory")) Select Case Trim(UCase(rs("ULCategory"))) Case "ANYPAGE" sql = "SELECT APBodyText FROM AnyPage WHERE APID = " & CStr(rs("ULCategoryID")) Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText If Not rsh.EOF Then rsh("APBodyText") = ReplaceImageFilename( rsh("APBodyText"), rs("ULOldFileName"), rs("ULDestPath"), rs("ULDestFileName") ) rsh.Update End If rsh.Close Case "EDUCATION" sql = "SELECT EABodyText FROM EdArticles WHERE EAID = " & CStr(rs("ULCategoryID")) Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText If Not rsh.EOF Then rsh("EABodyText") = ReplaceImageFilename( rsh("EABodyText"), rs("ULOldFileName"), rs("ULDestPath"), rs("ULDestFileName") ) rsh.Update End If rsh.Close Case "ADVERTISEMENT" sql = "SELECT AdHTMLText FROM AdViewer WHERE ADID = " & CStr(rs("ULCategoryID")) Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText If Not rsh.EOF Then rsh("AdHTMLText") = ReplaceImageFilename( rsh("AdHTMLText"), rs("ULOldFileName"), rs("ULDestPath"), rs("ULDestFileName") ) rsh.Update If Not ContainsHTML( rsh("AdHTMLText") ) Then s = CombinePathFilename( rs("ULDestPath"), rs("ULDestFileName") ) trc.Execute("UPDATE AdViewer SET AdImageURL='" & s & "' WHERE ADID=" & CStr(rs("ULCategoryID")) ) End If End If rsh.Close Case "TRADINGARENA" sql = "SELECT TPPictureURL FROM TradingPostAds WHERE TPID = " & CStr(rs("ULCategoryID")) Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText If Not rsh.EOF Then rsh("TPPictureURL") = CombinePathFilename( rs("ULDestPath"), rs("ULDestFileName") ) rsh.Update End If rsh.Close Case "CLINICS" sql = "SELECT CLPictureURL FROM Clinics WHERE CLID = " & CStr(rs("ULCategoryID")) Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText If Not rsh.EOF Then rsh("CLPictureURL") = CombinePathFilename( rs("ULDestPath"), rs("ULDestFileName") ) rsh.Update End If rsh.Close Case "CLINICSLOGO" sql = "SELECT CLPictureLogoURL FROM Clinics WHERE CLID = " & CStr(rs("ULCategoryID")) Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText If Not rsh.EOF Then rsh("CLPictureLogoURL") = CombinePathFilename( rs("ULDestPath"), rs("ULDestFileName") ) rsh.Update End If rsh.Close Case "ROPINGS" sql = "SELECT RPictureURL FROM Ropings WHERE RID = " & CStr(rs("ULCategoryID")) Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText If Not rsh.EOF Then rsh("RPictureURL") = CombinePathFilename( rs("ULDestPath"), rs("ULDestFileName") ) rsh.Update End If rsh.Close rsh.Close Case "ROPINGSLOGO" sql = "SELECT RPictureLogoURL FROM Ropings WHERE RID = " & CStr(rs("ULCategoryID")) Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText If Not rsh.EOF Then rsh("RPictureLogoURL") = CombinePathFilename( rs("ULDestPath"), rs("ULDestFileName") ) rsh.Update End If rsh.Close Case Else End Select rs.Close End Sub Sub UpdateImageLinksByCategory( ByRef trc, category, categoryid ) ''' ' This routine updates all image links of a given category and category ID... Example: if category="EDUCATION" ' and categoryid = "123" then education article (a record in the EdArticles table ) "123" will be searched ' for all old file names in the Uploads table and those file names will be replaced with the file name ' as stored on this site. This routine is called when a user updates an education (or other) record to ' update the record with the new image tags. ''' Dim rs, rsh If Len(categoryid) = 0 Then Exit Sub Select Case category Case "ANYPAGE" Set rs = trc.Execute( "SELECT * FROM Uploads WHERE ULStatus='PLACED' AND ULCategory='" & category & "' AND " & _ "ULCategoryID=" & categoryid & " ORDER BY ULID DESC" ) Do While Not rs.EOF sql = "SELECT APBodyText FROM AnyPage WHERE APID = " & CStr(categoryid) Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText If Not rsh.EOF Then rsh("APBodyText") = ReplaceImageFilename( rsh("APBodyText"), rs("ULOldFileName"), rs("ULDestPath"), rs("ULDestFileName") ) rsh.Update End If rsh.Close rs.MoveNext Loop rs.Close Case "EDUCATION" Set rs = trc.Execute( "SELECT * FROM Uploads WHERE ULStatus='PLACED' AND ULCategory='" & category & "' AND " & _ "ULCategoryID=" & categoryid & " ORDER BY ULID DESC" ) Do While Not rs.EOF sql = "SELECT EABodyText FROM EdArticles WHERE EAID = " & CStr(categoryid) Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText If Not rsh.EOF Then rsh("EABodyText") = ReplaceImageFilename( rsh("EABodyText"), rs("ULOldFileName"), rs("ULDestPath"), rs("ULDestFileName") ) rsh.Update End If rsh.Close rs.MoveNext Loop rs.Close Case "ADVERTISEMENT" Set rs = trc.Execute( "SELECT * FROM Uploads WHERE ULStatus='PLACED' AND ULCategory='" & category & "' AND " & _ "ULCategoryID=" & categoryid & " ORDER BY ULID DESC" ) Do While Not rs.EOF sql = "SELECT AdHTMLText FROM AdViewer WHERE ADID = " & CStr(categoryid) Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open sql, trc, adOpenDynamic, adLockOptimistic, adCmdText If Not rsh.EOF Then rsh("AdHTMLText") = ReplaceImageFilename( rsh("AdHTMLText"), rs("ULOldFileName"), rs("ULDestPath"), rs("ULDestFileName") ) rsh.Update End If rsh.Close rs.MoveNext Loop rs.Close Case "TRADINGARENA" Case Else End Select End Sub Function ReplaceImageFilename( ByVal src, oldfilename, newpath, newfilename ) ''' ' Searches for 0 And icnt < 300 ien = Instr( ist, lsrc, ">" ) st = Instr( ist, lsrc, loval ) If st < ien And st > 0 Then ''' ' the original oval of the source occurs between the ' tags so replace the original parm value with the ' new value. ''' ' Now look for the preceeding and ending quote marks. This gives us the ' string area to replace with "rw" as defined above. ''' st = InStrRev( lsrc, """", st ) en = Instr( st + 1, lsrc, """" ) lsrc = Mid( lsrc, 1, st ) & nval & Mid( lsrc, en ) ' update both the lower case and original src = Mid( src, 1, st ) & nval & Mid( src, en ) ' version of the input source. End If icnt = icnt + 1 ist = Instr( ien + 1, lsrc, ltag ) Loop ReplaceHTMLTagParameter = src End Function %> <% ''' ' The purpose of this include is to implement a quick and easy purchasing system. ' It is oriented around the "Payment" table which stores all the information realtive ' an order. It is intended for simple purchases only. Such as purchasing a membership ' or an advertisement. It does not have a shopping cart or order tracking. ' ' Dependencies: StringHandling.asp ' ' Prior to a call to this routine (CCForm) you should have called CreatePayment to create ' a record in the Payments table and obtain the PMID (PaymentID). PaymentID is passed ' to this routine which will create a form for posting to ECommerce Exchange. ''' Sub CCForm( ByRef trc, PaymentID ) Dim rs, sql, returnurl, trankey, amount, sequence PaymentID = DigitsOnly(PaymentID) If Len(PaymentID) = 0 Or IsNull(PaymentID) Then Call GeneralMessage("Credit card payment system is not available. We apologize for this inconvenience.", "#FF0000", "#FF0000") Exit Sub End If Set rs = trc.Execute( "SELECT * FROM Payments WHERE PMID = " & PaymentID ) If rs.EOF Then Call GeneralMessage("Credit card payment system is not available. We apologize for this inconvenience.", "#FF0000", "#FF0000") Exit Sub End If Randomize loginid = "xknvzmfzr8b" sequence = Int(1000 * Rnd) trankey = "4624Lgd7ZL8JE9g3" amount = Trim(Cdbl(rs("PMCCAmount"))) returnurl = "http://" & Request.ServerVariables("SERVER_NAME") & _ Request.ServerVariables("SCRIPT_NAME") & _ "?Action=CCReturn" %>
<% ret = InsertFP (loginid, trankey, amount, sequence) %> "> ">
Credit Card Number:
We do not accept American Express.
Expiration Date: <%=CCExpirationDateSelectList("x_Exp_Date", "" )%>
Billing First Name: ">
Billing Last Name:  ">
Billing Address: ">
Billing City: ">
Billing State and Zip: <%=StateSelectList( trc, "x_State", rs("PMBillingState"), False, False)%> ">
Item:  <%=rs("PMItemDescription")%>
Quantity:  <%=rs("PMItemQuantity")%>
Price Each:  <%=FormatCurrency(rs("PMItemPriceEach"),2)%>
Taxes:  <%=FormatCurrency( rs("PMItemTax"), 2)%>
Shipping:  <%=FormatCurrency( rs("PMItemShipping"), 2)%>
Total Cost:  <%=FormatCurrency( rs("PMCCAmount"), 2)%>
 

Rest assured that we use a secured internet channel to transmit your credit card information.



When you click the Place Order button, your credit card will be charged for the amount shown above.  
?Action=CCCancel">Click Here to Cancel Order
<% rs.Close End Sub Function CCProcessorResponse( ByRef trc ) ''' ' Processes response form data from CC Processor and returns the PMID record. ''' Dim PMInvoiceID, rsp CCProcessorResponse = Empty PMInvoiceID = CleanInput(Request.Form("x_invoice_num")) If Len("PMInvoiceID") = 0 Then Call MessageLog( trc, "F", "On return from CC processing the PMInvoiceID was empty. Can not process credit card." ) Exit Function End If sql = "SELECT * FROM Payments WHERE PMInvoiceID='" & PMInvoiceID & "'" Set rsp = Server.CreateObject("ADODB.Recordset") rsp.Open sql, trc, adOpenKeyset, adLockOptimistic, adCmdText If rsp.EOF Then Call MessageLog( trc, "F", "On return from CC processing the PMInvoiceID could not be found in database. Can not process credit card." ) rsp.Close Exit Function End If If rsp("PMStatus") <> "NEW" Then Call MessageLog( trc, "F", "Customer attempted to pay twice for his order. Check settlement report to make sure customer was not charged twice." ) rsp.Close Exit Function End If CCProcessorResponse = rsp("PMID") rsp("PMCCResponseCode") = CleanInput(Request.Form("x_response_code")) rsp("PMCCAuthCode") = CleanInput(Request.Form("x_auth_code")) rsp("PMCCResponseSubcode") = CleanInput(Request.Form("x_response_subcode")) rsp("PMCCResponseReasonCode") = CleanInput(Request.Form("x_response_reason_code")) rsp("PMCCResponseReasonText") = CleanInput(Request.Form("x_response_reason_text")) rsp("PMCCTransID") = CleanInput(Request.Form("x_trans_id")) If Len(Request.Form("x_Last_Name")) > 0 Then rsp("PMBillingLastName") = CleanInput(Request.Form("x_Last_Name")) If Len(Request.Form("x_First_Name")) > 0 Then rsp("PMBillingFirstName") = CleanInput(Request.Form("x_First_Name")) If Len(Request.Form("x_Address")) > 0 Then rsp("PMBillingAddress") = CleanInput(Request.Form("x_Address")) If Len(Request.Form("x_City")) > 0 Then rsp("PMBillingCity") = CleanInput(Request.Form("x_City")) If Len(Request.Form("x_State")) > 0 Then rsp("PMBillingState") = CleanInput(Request.Form("x_State")) If Len(Request.Form("x_Zip")) > 0 Then rsp("PMBillingZip") = CleanInput(Request.Form("x_Zip")) ''' ' Use these lines of code when testing without the use of QuickCommerce.net. ''' 'rsp("PMCCResponseCode") = "1" 'rsp("PMCCAuthCode") = "Y12345" 'rsp("PMCCResponseSubcode") = "001" 'rsp("PMCCResponseReasonCode") = "OKAY" 'rsp("PMCCResponseReasonText") = "TEST - OKAY" 'rsp("PMCCTransID") = "T12345" 'rsp("PMBillingLastName") = "TEST BILL LASTNAME" 'rsp("PMBillingFirstName") = "TEST BILL FIRSTNAME" 'rsp("PMBillingAddress") = "TEST BILL ADDRESS" 'rsp("PMBillingCity") = "TEST BILL CITY" 'rsp("PMBillingState") = "TS" 'rsp("PMBillingZip") = "00000" ''' ' If the response code indicating "payment received" changes then be sure to update the ' PaymentReceived procedure below as well. ''' If rsp("PMCCResponseCode") = "1" Then CCProcessorResponse = rsp("PMID") rsp("PMStatus") = "PAID" rsp("PMStatusDate") = Now() Call MessageLog( trc, "I", "Customer payment was accepted and approved by credit card processor.") Else rsp("PMStatus") = "UNPAID" rsp("PMStatusDate") = Now() Call MessageLog( trc, "W", "Customer order was declined by credit card processor.") End If rsp.Update rsp.Close End Function Function PaymentReceived( ByRef trc, SubCategory, SubCategoryID ) ''' ' This routine checks for payment received when given the subcategory (TradingArena, Ropings... ) ' and the subcategoryID (primary key) OR the payment ID. If you wish to search by payment ID ' (PMID) then set SubCategory="PMID" and SubCategoryID = the value of the desired PMID ''' Dim rs, sql PaymentReceived = False If Not ValidID( SubCategoryID ) Then Exit Function sql = "SELECT PMID, PMInvoiceID, PMStatus FROM Payments WHERE " Select Case SubCategory Case "TRADINGARENA" sql = sql & "PMSubCategory='TRADINGARENA' AND PMSubCategoryID=" & SubCategoryID & " " Case "PMID" sql = sql & "PMID=" & SubCategoryID & " " Case "PMInvoiceID" sql = sql & "PMInvoiceID='" & SubCategoryID & "' " Case Else Exit Function End Select sql = sql & "ORDER BY PMID DESC " Set rs = trc.Execute(sql) If rs.EOF Then Exit Function If rs("PMStatus")="PAID" Then PaymentReceived = True rs.Close End Function Function PaymentCreated( ByRef trc, SubCategory, SubCategoryID ) ''' ' This routine checks for payment received when given the subcategory (TradingArena, Ropings... ) ' and the subcategoryID (primary key) OR the payment ID. If you wish to search by payment ID ' (PMID) then set SubCategory="PMID" and SubCategoryID = the value of the desired PMID ''' Dim rs, sql PaymentCreated = "" sql = "SELECT PMID, PMInvoiceID, PMStatus FROM Payments WHERE PMStatus = 'NEW' AND " Select Case SubCategory Case "TRADINGARENA" sql = sql & "PMSubCategory='TRADINGARENA' AND PMSubCategoryID=" & SubCategoryID & " " Case "PMID" sql = sql & "PMID=" & SubCategoryID & " " Case "PMInvoiceID" sql = sql & "PMInvoiceID='" & SubCategoryID & "' " Case Else Exit Function End Select sql = sql & "ORDER BY PMID DESC " Set rs = trc.Execute(sql) If rs.EOF Then Exit Function Do While Not rs.EOF If trim(ucase(rs("PMStatus")))="NEW" Then PaymentCreated = rs("PMID") Exit Function End If rs.movenext Loop rs.Close End Function Function CreatePayment( ByRef trc, _ mmid, _ subcategory, _ subcategoryID, _ quantity, _ priceeach, _ shipping, _ tax, _ itemdescription ) ''' ' This routine creates a new payment entry in the payment table. The primary key PMID is ' returned and should be passed to the "CCFORM" routine above to display the credit card ' form for user's credit card number and other information. ''' Dim rs, rsm, tmp CreatePayment = Null If Len(mmid)=0 Or IsNull(mmid) Then Exit Function Set rsm = trc.Execute("SELECT * FROM Members WHERE MID = " & mmid ) If rsm.EOF Then Exit Function subcategoryID = CLng(DigitsOnly(CStr(subcategoryID))) If Len(CStr(subcategoryID)) = 0 Then subcategoryID = 0 Set rs = Server.CreateObject("ADODB.Recordset") rs.Open "Payments", trc, adOpenDynamic, adLockPessimistic, adCmdTable rs.AddNew tmp = GetUniqueID( trc, "PMT", 5 ) rs("PMMID") = mmid rs("PMSubCategory") = subcategory ' ex: TradingArena, Events, Advertisements rs("PMSubCategoryID") = subcategoryID ' primary key into TradingArena, Events or other table rs("PMInvoiceID") = tmp rs("PMBillingFirstName") = rsm("MFirstName") rs("PMBillingLastName") = rsm("MLastName") rs("PMBillingAddress") = rsm("MAddress1") rs("PMBillingCity") = rsm("MCity") rs("PMBillingState") = rsm("MState") rs("PMBillingZip") = rsm("MZip") rs("PMBillingEmail") = rsm("MEmail") rs("PMItemQuantity") = CLng( quantity ) rs("PMItemPriceEach") = CDbl( priceeach ) rs("PMItemShipping") = CDbl( shipping ) rs("PMItemTax") = CDbl( tax ) rs("PMItemDescription") = itemdescription rs("PMStatusDate") = Now() rs("PMStatus") = "NEW" rs("PMCCAmount") = (CDbl( quantity ) * CDbl( priceeach )) + CDbl(shipping) + CDbl(tax) rs.Update rs.Close rsm.Close Set rs = trc.Execute("SELECT PMID FROM Payments WHERE PMInvoiceID='" & tmp & "'" ) If rs.EOF Then CreatePayment = Null Else CreatePayment = rs("PMID") End If rs.Close End Function Function CCExpirationDateSelectList( selname, defval ) Dim selstr, i selstr = "" & vbCrLf CCExpirationDateSelectList = selstr End Function Function CCExpirationToDate( ccdate ) Dim mo, da, yr CCExpirationToDate = Null If Len(ccdate) <> 7 Or InStr( ccdate, "/" ) <> 3 Then Exit Function mo = DigitsOnly(Mid(ccdate,1,2)) yr = DigitsOnly(Mid(ccdate,4)) If Len(mo) <> 2 Or Len(yr) <> 4 Then Exit Function da = DaysInAMonth(mo) CCExpirationToDate = CDate( mo & "/" & da & "/" & yr ) End Function Function XOutCCNumber( ccnumber ) ''' ' Replaces all but the last 5 digits of CC number with X's ''' Dim lnum XOutCCNumber = String( 16, "X" ) If Len(ccnumber) < 6 Then Exit Function lnum = Right( ccnumber, 5 ) XOutCCNumber = String( Len(ccnumber) - 5, "X" ) & lnum End Function %> <% Function ValidPromotion( ByRef trc, pmcode ) ''' ' Is the promotion valid? ''' Dim rs, maxu, maxd ValidPromotion = True If Len(pmcode)=0 Or IsNull(pmcode) Then ValidPromotion = False Exit Function End If Set rs = trc.Execute("SELECT PMStatus, PMMaxUses, PMMaxDollars FROM Promotions WHERE PMCode = '" & pmcode & "'" ) If rs.EOF Then ValidPromotion = False Exit Function End If If rs("PMStatus") <> "ACTIVE" Then ValidPromotion = False Exit Function End If If Not IsNull(rs("PMMaxUses")) Then If CLng( rs("PMMaxUses") ) <= CLng( PromotionUseCount( trc, pmid ) ) Then maxu = True Else maxu = False End If End If If Not IsNull(rs("PMMaxDollars")) Then If CDbl( rs("PMMaxDollars") ) <= CDbl( PromotionDollarsUsed( trc, pmid ) ) Then maxd = True Else maxd = False End If End If If maxu And maxd Then ValidPromotion = False Exit Function End If rs.Close End Function Function PromotionUseCount( ByRef trc, pmid ) Dim rs PromotionUseCount = 0 If Not ValidID( pmid ) Then Exit Function Set rs = trc.Execute("SELECT COUNT(*) AS CNT FROM Payments WHERE PMPromotionID = " & pmid & " AND PMStatus='PAID'" ) If rs.EOF Then Exit Function If IsNull(rs("CNT")) Or IsEmpty(rs("CNT")) Then Exit Function PromotionUseCount = CLng( rs("CNT") ) End Function Function PromotionDollarsUsed( ByRef trc, pmid ) Dim rs PromotionDollarsUsed = CDbl(0.00) If Not ValidID( pmid ) Then Exit Function Set rs = trc.Execute( "SELECT SUM( PMItemQuantity * PMItemPriceEach ) AS TOT FROM Payments " & _ "WHERE PMPromotionID = " & pmid & " AND PMStatus='PAID' " ) If rs.EOF Then Exit Function If IsNull(rs("TOT")) Then Exit Function PromotionDollarsUsed = CDbl( rs("TOT") ) End Function Sub PayByPromotion( ByRef trc, promocode, pmtid ) ''' ' Updates the payment table to reflect payment via a promotion code. ''' Dim pmid If Not ValidID( pmtid ) Then Exit Sub If Not ValidPromotion( trc, promocode ) Then Exit Sub pmid = GetPromotionIDFromCode( trc, promocode ) trc.Execute( "UPDATE Payments SET " & _ "PMPromotionID = " & pmid & ", " & _ "PMCCNumber = 'PROMOTION', " & _ "PMStatus = 'PAID' " & _ "WHERE PMID = " & pmtid ) End Sub Function GetPromotionCode( ByRef trc, pmid ) Dim rs GetPromotionCode = Empty If Not ValidID(pmid) Then Exit Function Set rs = trc.Execute("SELECT PMCode FROM Promotions WHERE PMID = " & pmid ) If rs.EOF Then Exit Function GetPromotionCode = rs("PMCode") End Function Function GetPromotionIDFromCode( ByRef trc, pmcode ) Dim rs GetPromotionIDFromCode = Empty If Len(pmcode)=0 OR IsNull(pmcode) Then Exit Function Set rs = trc.Execute("SELECT PMID FROM Promotions WHERE PMCode = '" & pmcode & "'") If rs.EOF Then Exit Function GetPromotionIDFromCode = rs("PMID") End Function Sub DeletePromotion( ByRef trc, pmid ) Dim rs If Not ValidID(pmid) Then Exit Sub trc.Execute("DELETE FROM Promotions WHERE PMID = " & pmid ) End Sub %> <% '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: '::: ::: '::: This routine will attempt to identify any filespec passed ::: '::: as a graphic file (regardless of the extension). This will ::: '::: work with BMP, GIF, JPG and PNG files. ::: '::: ::: '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: '::: Based on ideas presented by David Crowell ::: '::: (credit where due) ::: '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: '::: blah blah Copyright *c* MM, Mike Shaffer blah blah ::: '::: blah blah ALL RIGHTS RESERVED WORLDWIDE blah blah ::: '::: blah blah Permission is granted to use this code blah blah ::: '::: blah blah in your projects, as long as this blah blah ::: '::: blah blah copyright notice is included blah blah ::: '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: '::: ::: '::: This function does most of the real work. It will attempt ::: '::: to read any file, regardless of the extension, and will ::: '::: identify if it is a graphical image. ::: '::: ::: '::: Passed: ::: '::: flnm => Filespec of file to read ::: '::: width => width of image ::: '::: height => height of image ::: '::: depth => color depth (in number of colors) ::: '::: strImageType=> type of image (e.g. GIF, BMP, etc.) ::: '::: ::: '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: function gfxSpex(flnm, width, height, depth, strImageType) dim strPNG dim strGIF dim strBMP dim strType strType = "" strImageType = "(unknown)" gfxSpex = False strPNG = chr(137) & chr(80) & chr(78) strGIF = "GIF" strBMP = chr(66) & chr(77) strType = GetBytes(flnm, 0, 3) if strType = strGIF then ' is GIF strImageType = "GIF" Width = lngConvert(GetBytes(flnm, 7, 2)) Height = lngConvert(GetBytes(flnm, 9, 2)) Depth = 2 ^ ((asc(GetBytes(flnm, 11, 1)) and 7) + 1) gfxSpex = True elseif left(strType, 2) = strBMP then ' is BMP strImageType = "BMP" Width = lngConvert(GetBytes(flnm, 19, 2)) Height = lngConvert(GetBytes(flnm, 23, 2)) Depth = 2 ^ (asc(GetBytes(flnm, 29, 1))) gfxSpex = True elseif strType = strPNG then ' Is PNG strImageType = "PNG" Width = lngConvert2(GetBytes(flnm, 19, 2)) Height = lngConvert2(GetBytes(flnm, 23, 2)) Depth = getBytes(flnm, 25, 2) select case asc(right(Depth,1)) case 0 Depth = 2 ^ (asc(left(Depth, 1))) gfxSpex = True case 2 Depth = 2 ^ (asc(left(Depth, 1)) * 3) gfxSpex = True case 3 Depth = 2 ^ (asc(left(Depth, 1))) '8 gfxSpex = True case 4 Depth = 2 ^ (asc(left(Depth, 1)) * 2) gfxSpex = True case 6 Depth = 2 ^ (asc(left(Depth, 1)) * 4) gfxSpex = True case else Depth = -1 end select else strBuff = GetBytes(flnm, 0, -1) ' Get all bytes from file lngSize = len(strBuff) flgFound = 0 strTarget = chr(255) & chr(216) & chr(255) flgFound = instr(strBuff, strTarget) if flgFound = 0 then exit function end if strImageType = "JPG" lngPos = flgFound + 2 ExitLoop = false do while ExitLoop = False and lngPos < lngSize do while asc(mid(strBuff, lngPos, 1)) = 255 and lngPos < lngSize lngPos = lngPos + 1 loop if asc(mid(strBuff, lngPos, 1)) < 192 or asc(mid(strBuff, lngPos, 1)) > 195 then lngMarkerSize = lngConvert2(mid(strBuff, lngPos + 1, 2)) lngPos = lngPos + lngMarkerSize + 1 else ExitLoop = True end if loop ' if ExitLoop = False then Width = -1 Height = -1 Depth = -1 else Height = lngConvert2(mid(strBuff, lngPos + 4, 2)) Width = lngConvert2(mid(strBuff, lngPos + 6, 2)) Depth = 2 ^ (asc(mid(strBuff, lngPos + 8, 1)) * 8) gfxSpex = True end if end if end function '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: '::: ::: '::: This function gets a specified number of bytes from any ::: '::: file, starting at the offset (base 1) ::: '::: ::: '::: Passed: ::: '::: flnm => Filespec of file to read ::: '::: offset => Offset at which to start reading ::: '::: bytes => How many bytes to read ::: '::: ::: '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: function GetBytes(flnm, offset, bytes) Dim objFSO Dim objFTemp Dim objTextStream Dim lngSize on error resume next Set objFSO = CreateObject("Scripting.FileSystemObject") ' First, we get the filesize Set objFTemp = objFSO.GetFile(flnm) lngSize = objFTemp.Size set objFTemp = nothing fsoForReading = 1 Set objTextStream = objFSO.OpenTextFile(flnm, fsoForReading) if offset > 0 then strBuff = objTextStream.Read(offset - 1) end if if bytes = -1 then ' Get All! GetBytes = objTextStream.Read(lngSize) 'ReadAll else GetBytes = objTextStream.Read(bytes) end if objTextStream.Close set objTextStream = nothing set objFSO = nothing end function '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: '::: ::: '::: Functions to convert two bytes to a numeric value (long) ::: '::: (both little-endian and big-endian) ::: '::: ::: '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: function lngConvert(strTemp) lngConvert = clng(asc(left(strTemp, 1)) + ((asc(right(strTemp, 1)) * 256))) end function function lngConvert2(strTemp) lngConvert2 = clng(asc(right(strTemp, 1)) + ((asc(left(strTemp, 1)) * 256))) end function ''' 'Function gfxTextExample ' ' '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: ' '::: Test Harness ::: ' '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: ' ' ' To test, we'll just try to show all files with a .GIF extension in the root of C: ' ' Set objFSO = CreateObject("Scripting.FileSystemObject") ' Set objF = objFSO.GetFolder("c:\") ' Set objFC = objF.Files ' ' response.write "" ' ' For Each f1 in objFC ' if instr(ucase(f1.Name), ".GIF") then ' response.write "" ' ' end if ' ' Next ' ' response.write "
" & f1.name & "" & f1.DateCreated & "" & f1.Size & "" ' ' if gfxSpex(f1.Path, w, h, c, strType) = true then ' response.write w & " x " & h & " " & c & " colors" ' else ' response.write " " ' end if ' ' response.write "
" ' ' set objFC = nothing ' set objF = nothing ' set objFSO = nothing ' 'End Function ''' %> <% Function AnyPageTitle( ByRef trc, APID ) Dim rs AnyPageTitle = Empty If Not ValidID(APID) Then Exit Function Set rs = trc.Execute("SELECT APTitle FROM AnyPage WHERE APID = " & APID ) If rs.EOF Then Exit Function AnyPageTitle = rs("APTitle") rs.Close End Function Function AnyPageBody( ByRef trc, APID ) Dim rs AnyPageBody = Empty If Not ValidID(APID) Then Exit Function Set rs = trc.Execute("SELECT APBodyText FROM AnyPage WHERE APID = " & APID ) If rs.EOF Then Exit Function AnyPageBody = rs("APBodyText") rs.Close End Function Function AnyPageHyperlinksRS( ByRef trc, APLID, recordcount ) ''' ' Returns a list of hyperlinks to "AnyPage" items based on the location ID (APLID) ' passed to this routine ''' Dim rs, sql, scriptname AnyPageHyperlinksRS = Null If Not ValidID(APLID) Then APLID = 0 recordcount = DigitsOnly( recordcount ) If Len(recordcount) > 0 Then recordcount = " TOP " & recordcount scriptname = "'" & Request.ServerVariables("SCRIPT_NAME") & "?Action=View&SubAction=AnyPage" sql = "SELECT " & recordcount & " APID, APHyperlinkTitle, " & _ scriptname & "&ID=' + CONVERT(VarChar, APID) AS Hyperlink " & _ "FROM AnyPage WHERE APStatus='NORMAL' AND APHideHyperlink='N' AND APAPLID = " & APLID Set rs = Server.CreateObject("ADODB.Recordset") rs.Open sql, trc, adOpenStatic, adLockReadOnly, adCmdText Set AnyPageHyperlinksRS = rs End Function Function AnyPageImageName( ByRef trc, APID, cnt ) ''' ' Searches for the 'cnt'th
> <% If rs("APHideTitle")="N" Then %> <% End If %>
<%=rs("APTitle")%>
<%=rs("APBodyText")%>
<% End If rs.Close End Sub %> <% Sub EMEmailForm ''' ' If Session("EMFromEmail") and/or Session("EMFromName") are NULL then the fields ' will not be prompted for. If they are EMPTY or LEN()=0 then Call WhiteSpacer( 10 ) Call GeneralMessage("To send email: type your message and click send.", "", "") %>
?Action=Email">
"> <% If Not ISNull(Session("EMFromEmail")) Then %> <% End If If Not ISNull(Session("EMFromName")) Then %> <% End If %>

From ( Your E-Mail ):

 ">

From ( Your Name ):

 ">

To:

 <%=Session("EMToEmail")%>

Subject:

 ">

Your Message:

Click to Send:

   

<% End Sub Function EMValidData Dim um EMValidData = True um = Empty Session("EMSubject") = CleanInput(Request.Form("EMSubject")) Session("EMMessage") = CleanInput(Request.Form("EMMessage")) Session("EMFromEmail") = CleanInput(Request.Form("EMFromEmail")) Session("EMFromName") = CleanInput(Request.Form("EMFromName")) Session("EMReturnURL") = CleanInput(Request.Form("EMReturnURL")) If Len(Session("EMMessage")) < 2 Then um = um & "Please type your message in the box labeled 'Your Message Here:'
" EMValidData = False End If If Len(Session("EMSubject")) < 1 Then um = um & "Please enter the subject of this e-mail.
" EMValidData = False End If If Not EMValidEmail(Session("EMFromEmail")) Then um = um & "Please enter your email address.
" EMValidData = False End If Call AddMessageError( um ) End Function Sub EMSendEmail ''' ' 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 If Not EMValidEmail(Session("EMToEmail")) Then Exit Sub On Error Resume Next Set JMail = Server.CreateObject("JMail.SMTPMail") JMail.ServerAddress = "mail.prwebstudio.com" JMail.Sender = Session("EMFromEmail") JMail.SenderName = Session("EMFromName") JMail.AddRecipient Session("EMToEmail") JMail.Subject = Session("EMSubject") JMail.Body = Session("EMMessage") JMail.Priority = 3 JMail.LazySend = True JMail.Execute JMail.Close On Error Goto 0 End Sub Function EMEmailLink( linktext, action, subaction, id ) ''' ' Returns a hyperlink which is used to open up an email item. ''' Dim el If Len( linktext ) > 30 Then linktext = "Click Here" el = " 0 Then el = el & "?Action=" & action & "&SubAction=" & subaction & "&ID=" & id el = el & """>" & linktext & "" EMEmailLink = el End Function Sub EMSetupSessionVars( EMToEmail, EMFromEmail, EMFromName, EMSubject, EMMessage ) Session("EMToEmail") = EMToEmail Session("EMFromEmail") = EMFromEmail Session("EMFromName") = EMFromName Session("EMSubject") = EMSubject Session("EMMessage") = EMMessage End Sub Sub EMSetupSessionVarsByApp( ByRef trc, apptype, id ) Dim sql, rs If Not ValidID( id ) Then Exit Sub Select Case UCase(apptype) Case "PARTNERFINDER" If Not ValidID(Session("MemberID")) Then Exit Sub Session("EMToEmail") = GetMemberEmail( trc, id ) Session("EMFromEmail") = GetMemberEmail( trc, Session("MemberID")) Session("EMFromName") = GetMemberName( trc, Session("MemberID")) Session("EMSubject") = "TeamRoper.com Partner Finder" If Len(Session("PFSearchSQL")) > 0 Then Session("EMReturnURL") = Request.ServerVariables("SCRIPT_NAME") & _ "?Action=ShowSearchResults" Else Session("EMReturnURL") = Request.ServerVariables("SCRIPT_NAME") & _ "?Action=ShowSearch" End If Case "EVENT" sql = "SELECT EVMID, EVName, EVEmail FROM Events WHERE EVID = " & id Set rs = trc.Execute(sql) If rs.EOF Then Exit Sub Session("EMReturnURL") = Request.ServerVariables("SCRIPT_NAME") & _ "?Action=View&SubAction=Event&ID=" & id If Len(rs("EVEmail")) > 0 Then Session("EMToEmail") = rs("EVEmail") Else Session("EMToEmail") = GetMemberEmail( trc, rs("EVMID") ) End If Session("EMSubject") = rs("EVName") rs.Close Case "TRADING" Session("EMReturnURL") = Request.ServerVariables("SCRIPT_NAME") & _ "?Action=View&SubAction=TradingAd&ID=" & id sql = "SELECT TPTitle, TPID, TPEmail, TPMID FROM TradingPostAds WHERE TPID = " & id Set rs = trc.Execute( sql ) If rs.EOF Then Exit Sub Session("EMSubject") = rs("TPTitle") Session("EMToEmail") = rs("TPEmail") rs.Close Case Else ''' ' Do nothing, the caller has set up the session variables. ''' End Select End Sub Function EMValidEmail( email ) EMValidEmail = True If Len(email) < 6 Or IsNull(email) Or IsEmpty(email) Then EMValidEmail = False Exit Function End If If InStr(email,"@")=0 Then EMValidEmail = False Exit Function End If If InStr(email,".")=0 Then EMValidEmail = 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 Sub EMClearSessVars( opt ) If opt = "ALL" Then Session("EMReturnURL") = Empty End If Session("EMSubject") = Empty Session("EMFromEmail") = Empty Session("EMFromName") = Empty Session("EMMessage") = Empty Session("EMToEmail") = Empty End Sub %>