<% '----------------------------------------------------------- ' Q-Shop - Home Page ' Developed by QuadComm Inc. for use with Q-Shop ' © Copyright QuadComm,Inc. 2003. All rights reserved ' http://quadcomm.com '----------------------------------------------------------- If NOT Application("Shop_Open") Then Response.Redirect("shopclosed.asp") %> <% '============================================================== ' This file contains the database configuration. It also opens ' a connection object (Conn) using OpenCnx. ' The file also contains some common function. '============================================================== 'Global scope variables: Dim conn 'Connection object Dim dbPassword 'Database password '=========================================================== ' Sub: OpenCnx ' Desc: 'Opens connection conn if it is not already open. ' >>> Please, modify configuration with correct values <<< '=========================================================== Sub OpenCnx (ByRef conn) If NOT IsObject(conn) Then On Error Resume Next Dim ConnStr 'Connection string Dim dbPassword 'Database password Set conn = Server.CreateObject("ADODB.Connection") dbPassword = "QS2003p" ' <<<< Change any new Access database password here. '------------------------------------------------------- 'Pick ONE of the following configurations and comment the others 'For additional tech. info see ' - http://www.able-consulting.com/ADO_Conn.htm '------------------------------------------------------- '1. Configuration for System DSN 'ConnStr = "DSN=DSN_Name;uid=;pwd=" & dbPassword '2. Configuration for file DSN (DSN-Less) 'ConnStr = "DBQ=d:\inetpub\quadcomm.com\db\store.mdb;Driver={Microsoft Access Driver (*.mdb)};uid=;pwd=" & dbPassword '3. Configuration for OLEDB drivers (more efficient) 'a) Example of OLEDB connection with OLEDB 3.51 (if you have to use this one you may want to 'consider installing a newer version of MDAC 'ConnStr = "Provider=Microsoft.Jet.OLEDB.3.51; Data Source=C:\web\quadcomm\db\store.mdb; Jet OLEDB:Database Password=" & dbPassword 'b)Example of OLEDB connection on Windows 2000 server (version 4.0) 'ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=C:\web\quadcomm\db\store.mdb; Jet OLEDB:Database Password=" & dbPassword ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=C:\Web\starquestpublishing\db\store2K.mdb; Jet OLEDB:Database Password=" & dbPassword 'c)Example of OLEDB connection on Windows 2000 server (version 4.0) and MS SQL Server 7.0/2000 'ConnStr = "Provider=SQLOLEDB; Data Source=(local); Initial Catalog=QShopDB; User ID=qshop_usr; Password=" & dbPassword 'ConnStr = "Provider=SQLOLEDB; Data Source=(local); Initial Catalog=Q-Shop; User ID=sa; Password=" '------------------------------------------------------- conn.open ConnStr 'Open connection object '------------------------------------------------------- 'When the site is working we recommend you to comment 'Option 1 and uncomment option 2 '------------------------------------------------------- If conn.errors.count > 0 then Dim counter For counter = 0 to conn.errors.count-1 If int(conn.errors(counter).number) <> 0 Then ' Option 1 response.write "Error # :" & conn.errors(counter).number & "

" response.write "Error desc. : " & conn.errors(counter).description & "

" If conn.errors(counter).number = -2147467259 Then response.write "Suggestion: Check the connection string ConnStr in conx.asp and make sure that only one option is not commented using '.

" End If set conn = nothing Response.End 'Option 2 'Redirect user to an error page if there is a connetion error. set conn = nothing Response.Redirect("connerror.htm") Response.End End If next conn.errors.Clear End If 'If you leave the following line commented, all errors will be by-passed unless there is 'a line like this somewhere in the code. On Error Goto 0 End If End Sub '=========================================================== ' Sub: CloseCnx ' Desc: Closes and destroys connection object "conn". '=========================================================== Sub CloseCnx (ByRef conn) If IsObject(conn) Then conn.close set conn = nothing End If End Sub '======================================================================== ' Basic Currency Functions '=========================================================== ' Function: FormatPrice ' Desc: Returns a price formatted including taxes when tax ' model is EU and Show_VAT is enabled. '=========================================================== Function FormatPrice (ByVal nCost, ByVal nTax, ByVal nTaxable) If IsNumeric(nCost) Then If Tax_ShowVAT = 1 AND Tax_Model = "EU" AND nTaxable = 1 Then FormatPrice = FormatNumber(nCost * (1+nTax/100.0),2) Else FormatPrice = FormatNumber(nCost,2) End If Else FormatPrice = "Error!" End If End Function '=========================================================== ' Function: FormatDefCurr (num) ' Desc: Returns a price formatted as currency using the default ' currency settings. '=========================================================== Function FormatDefCurr (num) 'Formats a number (num) as a currency figure with 2 decimal digits If IsNumeric(num) Then FormatDefCurr = Replace(shop_DefCurName,"#",FormatNumber(num,2)) Else FormatDefCurr = "Error!" End If End Function '=========================================================== ' Function: FormatSecCurr (ByVal num) ' Desc: Returns a price converted and formatted as currency ' using the secondary currency settings. '=========================================================== Function FormatSecCurr (ByVal num) 'Converts and formats a number (num) as a secondary currency figure with 2 decimal digits If IsNumeric(num) Then FormatSecCurr = Replace(shop_SecCurName,"#",FormatNumber (num / (CDbl(shop_SecCurConv)),2)) Else FormatDefCurr = "Error!" End If End Function '=========================================================== ' Function not currently used '=========================================================== 'Function FormatDefCurrTax (ByVal nCost, ByVal nTaxRate) ' If IsNumeric(nCost) AND IsNumeric(nTaxRate) Then ' FormatDefCurrTax = FormatDefCurr(nCost*(1+ntaxrate/100.0)) ' Else ' FormatDefCurrTax = "Error!" ' End If 'End Function '=========================================================== ' Function: GetDBCurrentDateTime ' Desc: Returns the current date and time in a format ' accepted by the current database (Access or SQL Server) '=========================================================== Function GetDBCurrentDateTime Dim strDateDelim, dtDate If shop_DB = "SQL" Then strDateDelim = "" 'MS SQL Server dtDate = "GETDATE()" Else strDateDelim = "#" 'MS Access 'Use with Access: It must be in US format MM/DD/YY regardless of local settings. dtDate = Month(Date) & "/" & Day(Date) & "/" & Year(Date) & " " & Time End If 'Build and return final date/time GetDBCurrentDateTime = strDateDelim & dtDate & strDateDelim End Function '=========================================================== ' Function: ParseInj ' Desc: Parses a string for SQL injection attacks. '=========================================================== Function ParseInj(strIn) ParseInj = Replace(strIn, "'", "''") End Function '=========================================================== ' Function: RemoveHTML ' Desc: Removes HTML tags from a string '=========================================================== Function RemoveHTML(sText) Dim RegEx Set RegEx = New RegExp RegEx.Pattern = "<[^>]*>" RegEx.Global = True RegEx.IgnoreCase = True RemoveHTML = RegEx.Replace(sText, "") End Function '======================================== 'Create connection object Call OpenCnx (conn) '======================================== %> <% '----------------------------------------------------------- ' Q-Shop Parameter/Settings definition ' Developed by QuadComm Inc. for use with Q-Shop ' © Copyright QuadComm, Inc. 2003. All rights reserved '----------------------------------------------------------- '======================================================================== ' CONSTANTS HARDCODED '======================================================================== '========================================= 'Collect Credit Card Details '========================================= Dim bCollectCCDetails 'Indicates whether credit card details fields should be shown 'If True CC fields are collected and saved to the database (True|False) 'Use True when processing credit cards manually 'Choose of the two options and comment the other one: bCollectCCDetails = False 'Display CC details fields 'bCollectCCDetails = True 'Don't display CC details fields '========================================= '========================================= 'Paypal configuration '========================================= Dim bEnablePaypal 'When True a paypal option will be displayed (True|False). (default is False) 'Choose of the two options and comment the other one: bEnablePaypal = True 'Enable Paypal 'bEnablePaypal = False 'Disable Paypal '========================================= '========================================= 'Cash on Delivery (COD) configuration '========================================= Dim bEnableCOD 'When True a COD option will be displayed (True|False). (default is True) 'Choose of the two options and comment the other one: 'bEnableCOD = True 'Enable COD bEnableCOD = False 'Disable COD '========================================= '========================================= 'External payment gateway link configuration '========================================= Dim bExtGateway 'Indicates whether the credit card payment is processed in an external site 'If True the credit card options including details won't be shown. (True|False) 'Choose of the two options and comment the other one: 'bExtGateway = True 'Use external gateway bExtGateway = False 'No external gateway '========================================= '========================================= 'CC extra fields configuration '========================================= Dim bShow_CCIssueNumber 'Display issue number field? (True|False) bShow_CCIssueNumber = False Dim bShow_CVV 'Display CVV number field? (True|False) bShow_CVV = True Dim bShow_L4SSN 'Display last 4 SNN digits field? (True|False) bShow_L4SSN = False 'Used for Transact-Secure with Authorize.Net '========================================= '========================================= 'Order email confirmation '========================================= Dim bSendMailConf 'Defines whether a mail confirmation should be sent (True|False). Default to True bSendMailConf = True 'Default True: Send email confirmation message. '======================================================================== 'Get secure URL details. If there is a secure URL get the non-secure as well. '======================================================================== Dim strNonSecPath Dim strSecPath strSecPath = Application("SECUREURL") If strSecPath <> "" Then strNonSecPath = Application("URL") 'Hardcode if necessary: 'strSecPath = "https://www.secure-us.net/quadcomm/demo/" 'strNonSecPath = "http://quadcomm.com/demo/" '======================================================================== '======================================================================== ' Logo file paths. If you need to have content other than images, you can ' hardcode the value here. '======================================================================== Dim LogoURL, smLogoURL, LineLogoURL 'URL of the main logo. Double quote all quote characters 'LogoURL = "" If Application("LogoURL") <> "" Then LogoURL = "" Else LogoURL = "" End If 'URL of the small logo on the left-hand side bar. Double quote all quote characters 'smLogoURL = "" If Application("smLogoURL") <> "" Then smLogoURL = "" Else smLogoURL = "" End If 'URL of the small logo displayed when a product has no picture (called in inc/line.asp). Double quote all quote characters. This could also be text or HTML code. 'LineLogoURL = "" If Application("NotAvailImg") <> "" Then LineLogoURL = "" Else LineLogoURL = "(No image)" End If '======================================================================== '======================================================================== Dim MaxItems 'Defines the maximum number of products per page when 'browsing products in the shop '======================================================================== MaxItems = 20 'Maximum number of items displayed at once '======================================================================== 'Set browse layout types: S (single), M (multiple) ' Single: Each product has its own add to cart button ' Multiple: All products in a page share an add to cart button so that ' multiple products can be added to the cart at the same time. '======================================================================== Dim sBrowseSearch 'Browse type for products page Dim sBrowseOffer 'Browse type for Offers page Dim sBrowseManu 'Browse type for Manufacturers page Dim sBrowseFeat 'Browse type for Featured Products page Dim sBrowseMyList 'Browse type for My List page sBrowseSearch = "S" 'Browse search results sBrowseOffer = "M" 'Browse offers page sBrowseManu = "S" 'Browse by brands/manufacturer list page sBrowseFeat = "M" 'Browse featured products sBrowseMyList = "M" 'Browse type for My List page '======================================================================== '======================================================================== ' Related Products Parameters (used in details.asp) '======================================================================== Dim RelProdsLayout 'Related Products Layout Dim RelProdsTableColumns 'Number of related products per line when using "Thumbnail" layout RelProdsLayout = "Thumbnail" '(Thumbnail|List) RelProdsTableColumns = 3 '======================================================================== '======================================================================== ' Email confirmation settings '======================================================================== Dim sMailFormat 'Related Products Layout (TEXT|HTML) sMailFormat = "TEXT" '(TEXT|HTML) 'sMailFormat = "HTML" '(TEXT|HTML) '======================================================================== '======================================================================== ' CONSTANTS LOADED DYNAMICALLY FROM DB, ETC. '======================================================================== ' You shouldn't edit the parameters below in normall circumstances ' unless you want to override the default way of loading them via the ' database and the control panel. '======================================================================== '======================================================================== ' Shop Settings definitions '======================================================================== Dim shop_DefCurName, shop_SecCurName, shop_SecCurConv, shop_CompanyName, shop_Mail, shop_Title, shop_StockControl Dim shop_DB, shop_MailSystem, shop_URL, shop_ShowTerms Dim shop_TempPath 'Temporary folder (to write temporary files). This folder requires write permissions 'for the IUSR_ user (used by the web server). shop_TempPath = Application("TempPath") '***** CONFIGURE IN CONTROL PANEL ***** ' Currency shop_DefCurName = Application("DefCurName") shop_SecCurName = Application("SecCurName") shop_SecCurConv = Application("SecCurConv") 'Others shop_CompanyName = Application("CompanyName") shop_Mail = Application("Mail") shop_Title = Application("Title") If Application("ShowTerms") = "1" Then shop_ShowTerms = True Else shop_ShowTerms = False End If If Application("StockControl") = "1" Then shop_StockControl = True Else shop_StockControl = False End If shop_DB = Application("DBSystem") shop_MailSystem = Application("MailSystem") shop_URL = Application("URL") 'Shop base URL. 'If the URL doesn't end with "/" add it: If RIGHT(shop_URL,1) <> "/" Then shop_URL = shop_URL & "/" 'Colour settings Dim CART_HEAD_BG, CART_HEAD_FONT, CART_BODY_BG, LMENU_BG, LMENU_FONT, LMENU_SUB_FONT, TMENU_BG Dim TMENU_FONT, SEC_BG, SEC_FONT, DETAILS_BG, DETAILS_HEAD_BG, DETAILS_HEAD_FONT CART_HEAD_BG = Application("CART_HEAD_BG") CART_HEAD_FONT = Application("CART_HEAD_FONT") CART_BODY_BG = Application("CART_BODY_BG") LMENU_BG = Application("LMENU_BG") LMENU_FONT = Application("LMENU_FONT") LMENU_SUB_FONT = Application("LMENU_SUB_FONT") TMENU_BG = Application("TMENU_BG") TMENU_FONT = Application("TMENU_FONT") SEC_BG = Application("SEC_BG") SEC_FONT = Application("SEC_FONT") DETAILS_BG = Application("DETAILS_BG") DETAILS_HEAD_BG = Application("DETAILS_HEAD_BG") DETAILS_HEAD_FONT = Application("DETAILS_HEAD_FONT") 'Tax Settings Dim Tax_Model, Tax_ShowVAT Tax_Model = Application("Tax_Model") 'EU, US or CAN supported Tax_ShowVAT = Application("Tax_ShowVAT") '1: Show VAT included. '======================================================================== ' DB Constant definitions (From adovbs.inc) ' Remove if including adovbs.inc '======================================================================== '---- CursorTypeEnum Values ---- Const adOpenForwardOnly = 0 Const adOpenKeyset = 1 Const adOpenDynamic = 2 Const adOpenStatic = 3 '---- LockTypeEnum Values ---- Const adLockReadOnly = 1 Const adLockPessimistic = 2 Const adLockOptimistic = 3 Const adLockBatchOptimistic = 4 '---- CursorLocationEnum Values ---- Const adUseServer = 2 Const adUseClient = 3 '---- Other ---- Const adExecuteNoRecords = &H00000080 %> <% '----------------------------------------------------------- ' Q-Shop Add-On API - Optional Package ' Developed by QuadComm Inc. for use with Q-Shop ' © Copyright QuadComm, Inc. 2003. All rights reserved '----------------------------------------------------------- ' This page contains the functions to call Add-on features ' If your installation includes the optional Add-on package ' the functions will call the respective features. Otherwise ' the methods will be empty and will do nothing. '----------------------------------------------------------- %> <% '----------------------------------------------------------- ' Q-Shop Product List class ' Developed by QuadComm Inc. for use with Q-Shop ' © Copyright QuadComm, Inc. 2003. All rights reserved '----------------------------------------------------------- '-------------------------------------------------------------------- ' Class: ProductList ' Description: ' This class is used to control user interface operations for reviews. ' It acts as UI layer and Business layer talking to the Data Access ' layer directly. ' It is used by the shop public frontend only. '-------------------------------------------------------------------- Class ProductList Public ListType 'List Type (Top10, etc) Public Align 'Table align (left|right|center) Public Width 'Table width '-------------------------------------------------------------------- ' Sub Class_Initialize ' Description: Initialises the class instance. '-------------------------------------------------------------------- Private Sub Class_Initialize 'Set default values ListType = "TOP10" Width = "" End Sub '-------------------------------------------------------------------- ' Sub ShowReviews ' Description: Displays user reviews for a product. ' Preconditions: ' - ProductID must be set before calling this method. '-------------------------------------------------------------------- Public Sub ShowList() Dim sSQL Dim aryData Dim sPerc sPerc = "%" sSQL = "Select OrderNo, ProductListType.Description AS ProductListDesc, ProductID, Products.Name " & _ "FROM ProductList, ProductListType, Products " & _ "WHERE ProductList.ProductListTypeID = ProductListType.ProductListTypeID AND " & _ "ProductList.ProductID = Products.ProdID AND Products.Show = 1 " & _ "ORDER BY OrderNo" aryData = GetDataArray(sSQL) If IsArray(aryData) Then Response.Write ("" & _ "") Response.Write ("
Top 10 Products
") For i = 0 to UBound(aryData,2) Response.Write("" & vbCrLf) Next Response.Write("
" & aryData(0,i) & ". " & aryData(3,i) & "

") End If End Sub Private Function GetDataArray(strSQL) Dim aryRP Dim RPRs If strSQL = "" Then err.Raise 1, "GetDataArray", "No SQL query defined" End If set RPRs = conn.Execute (strSQL) If NOT (RPRs.EOF AND RPRs.BOF) Then aryRP = RPRs.GetRows RPRs.Close GetDataArray = aryRP Else 'Response.Write("no data") End If set RPRs = nothing End Function End Class %> <% '----------------------------------------------------------- ' Q-Shop User Reviews Module ' Developed by QuadComm Inc. for use with Q-Shop ' © Copyright QuadComm, Inc. 2003. All rights reserved '----------------------------------------------------------- '-------------------------------------------------------------------- ' Class: UserReviewDAL (Data Access Layer) ' Description: ' This class is used for data access to user product ' reviews. ' It is used by the shop frontend and the administration site '-------------------------------------------------------------------- Class UserReviewDAL Public ProductID Public userID Public userRating Public userName Public userLocation Public userCountry Public reviewTitle Public reviewText Public reviewDate Public reviewed Public reviewId '-------------------------------------------------------------------- ' Function Approve ' Description: Sets the reviewed flag or a user review as "reviewd". ' Only reviewed reviews are displayed. ' Preconditions: ' - reviewId must be set before calling this method '-------------------------------------------------------------------- Public Function Approve Dim sSQL Approve = -1 'Default: Problem updating If reviewId = "" Then Exit Function sSQL = "UPDATE UserReviews SET reviewed = 1 WHERE ReviewID = " & reviewId conn.Execute sSQL , , adExecuteNoRecords Approve = 0 'Updated successfully End Function '-------------------------------------------------------------------- ' Function Disapprove ' Description: Sets the reviewed flag or a user review as "not reviewed". ' Only reviewed reviews are displayed. ' Preconditions: ' - reviewId must be set before calling this method '-------------------------------------------------------------------- Public Function Disapprove Dim sSQL Disapprove = -1 'Default: Problem updating If reviewId = "" Then Exit Function sSQL = "UPDATE UserReviews SET reviewed = 0 WHERE ReviewID = " & reviewId conn.Execute sSQL , , adExecuteNoRecords Disapprove = 0 'Updated successfully End Function '-------------------------------------------------------------------- ' Function Delete ' Description: Deletes a user review from the database. ' Preconditions: ' - reviewId must be set before calling this method '-------------------------------------------------------------------- Public Function Delete Dim sSQL Delete = -1 'Default: Problem updating If reviewId = "" Then Exit Function sSQL = "DELETE FROM UserReviews WHERE ReviewID = " & reviewId conn.Execute sSQL , , adExecuteNoRecords Delete = 0 'Updated successfully End Function '-------------------------------------------------------------------- ' Function GetRatingAvg ' Description: Returns the average rating for a product ' Preconditions: ' - ProductID must be set before calling this method '-------------------------------------------------------------------- Public Function GetRatingAvg If ProductID = "" Then Exit Function 'Get reviews from DB and return array Dim nRatingAvg Dim strSQL Dim rsReview nRatingAvg = -1 strSQL = "SELECT AVG(UserRating) As RatingAvg FROM UserReviews " & _ "WHERE ProdId = '" & ProductID & "' " & _ "AND Reviewed = 1 " set rsReview = conn.Execute (strSQL) If NOT (rsReview.EOF AND rsReview.BOF) Then nRatingAvg = rsReview("RatingAvg") rsReview.Close 'If no reviews were found it returns one record with value "null". If IsNull(nRatingAvg) Then nRatingAvg = -1 End If End If set rsReview = nothing GetRatingAvg = nRatingAvg End Function '-------------------------------------------------------------------- ' Function GetPublic ' Description: Returns all public reviews for a product (reviewed) ' Preconditions: ' - ProductID must be set before calling this method ' Returns: ' - Array with all reviews. '-------------------------------------------------------------------- Public Function GetPublic If ProductID = "" Then Exit Function 'Get reviews from DB and return array Dim aryReviews Dim strSQL Dim rsReview strSQL = "SELECT ReviewID, ProdID, userID, UserRating, userName, UserLocation, " & _ "UserCountry, ReviewTitle, ReviewText, ReviewDate, Reviewed " & _ "FROM UserReviews " & _ "WHERE ProdId = '" & ProductID & "' " & _ "AND Reviewed = 1 " & _ "ORDER BY ReviewDate DESC" set rsReview = conn.Execute (strSQL) If NOT (rsReview.EOF AND rsReview.BOF) Then aryReviews = rsReview.GetRows rsReview.Close End If set rsReview = nothing GetPublic = aryReviews End Function '-------------------------------------------------------------------- ' Function SaveReview ' Description: Saves a review to the database. ' Preconditions: ' - All review properties must be set before calling this function ' Returns: ' - Error code: ' - 0: Successfully saved ' - -10: required data missing ' - -1: Error saving review '-------------------------------------------------------------------- Public Function SaveReview SaveReview = -10 If ProductID = "" Then Exit Function If userRating = "" Then Exit Function If reviewText = "" Then Exit Function If reviewTitle = "" Then Exit Function If ProductID = "" Then Exit Function SaveReview = -1 'Save review to DB and return status Dim strSQL Dim rsReview Set rsReview = Server.CreateObject("ADODB.Recordset") strSQL = "SELECT * FROM UserReviews WHERE 1=0" rsReview.Open strSQL, Conn, adOpenStatic, adLockOptimistic rsReview.AddNew rsReview("ProdID") = ProductID rsReview("userID") = userID rsReview("userRating") = userRating rsReview("userName") = userName rsReview("userLocation") = userLocation rsReview("userCountry") = userCountry rsReview("reviewTitle") = reviewTitle rsReview("reviewText") = reviewText rsReview("reviewDate") = Date rsReview("reviewed") = 0 rsReview.Update Set rsReview = nothing SaveReview = 0 End Function '-------------------------------------------------------------------- ' Function GetUnapproved ' Description: Returns all reviews pending admin review/approval ' Returns: ' - Array containing all reviews that haven't been reviewed/approved '-------------------------------------------------------------------- Public Function GetUnapproved 'Get reviews from DB and return array Dim aryReviews Dim strSQL Dim rsReview strSQL = "SELECT ReviewID, UserReviews.ProdID, UserID, UserRating, UserName, UserLocation, " & _ "UserCountry, ReviewTitle, ReviewText, ReviewDate, Reviewed, Products.Name " & _ "FROM UserReviews, Products " & _ "WHERE Reviewed = 0 " & _ "AND Products.ProdID = UserReviews.ProdID " & _ "ORDER BY ReviewDate DESC" set rsReview = conn.Execute (strSQL) If NOT (rsReview.EOF AND rsReview.BOF) Then aryReviews = rsReview.GetRows rsReview.Close End If set rsReview = nothing GetUnapproved = aryReviews End Function '-------------------------------------------------------------------- ' Function GetProductList ' Description: Returns all reviews for a particular product ' Preconditions: ' - Product ID must be set before calling this function ' Returns: ' - Array containing all reviews that haven't been reviewed/approved '-------------------------------------------------------------------- Public Function GetProductList If ProductID = "" Then Exit Function 'Get reviews from DB and return array Dim aryReviews Dim strSQL Dim rsReview strSQL = "SELECT ReviewID, UserReviews.ProdID, userID, UserRating, userName, UserLocation, " & _ "UserCountry, ReviewTitle, ReviewText, ReviewDate, Reviewed, Products.Name " & _ "FROM UserReviews, Products " & _ "WHERE UserReviews.ProdId = '" & ProductID & "' " & _ "AND Products.ProdID = UserReviews.ProdID " & _ "ORDER BY ReviewDate DESC" set rsReview = conn.Execute (strSQL) If NOT (rsReview.EOF AND rsReview.BOF) Then aryReviews = rsReview.GetRows rsReview.Close End If set rsReview = nothing GetProductList = aryReviews End Function End Class %> <% '----------------------------------------------------------- ' Q-Shop User Reviews Module ' Developed by QuadComm Inc. for use with Q-Shop ' © Copyright QuadComm, Inc. 2003. All rights reserved '----------------------------------------------------------- '-------------------------------------------------------------------- ' Class: UserReviewUI ' Description: ' This class is used to control user interface operations for reviews. ' It acts as UI layer and Business layer talking to the Data Access ' layer directly. ' It is used by the shop public frontend only. '-------------------------------------------------------------------- Class UserReviewUI Public ProductID Private objUserReviewDAL Private sUserMsg '-------------------------------------------------------------------- ' Sub Class_Initialize ' Description: Initialises the class instance. '-------------------------------------------------------------------- Private Sub Class_Initialize Set objUserReviewDAL = New UserReviewDAL End Sub '-------------------------------------------------------------------- ' Sub Class_Terminate ' Description: Terminates the class instance cleaning up objects. '-------------------------------------------------------------------- Private Sub Class_Terminate Set objUserReviewDAL = Nothing End Sub '-------------------------------------------------------------------- ' Sub ShowReviews ' Description: Displays user reviews for a product. ' Preconditions: ' - ProductID must be set before calling this method. '-------------------------------------------------------------------- Public Sub ShowReviews Dim aryReviews Dim i,j Dim nRatingAvg Dim param Dim sURLParams If ProductID = "" Then Exit Sub objUserReviewDAL.ProductID = ProductID nRatingAvg = objUserReviewDAL.GetRatingAvg If nRatingAvg > 0 Then aryReviews = objUserReviewDAL.GetPublic End If 'Display the review header Response.Write ("

") Response.Write ("

User reviews

") If sUserMsg <> "" Then Response.Write ("
" & sUserMsg & "
") If nRatingAvg > 0 Then Response.Write ("

Average customer review: ") For j = 1 to nRatingAvg Response.Write ("") Next If nRatingAvg-Int(nRatingAvg) >= 0.5 Then Response.Write ("") End If Response.Write(" | ") End If Response.Write ("Write a review

") 'If there are reviews, display them If IsArray(aryReviews) Then For i = 0 to UBound(aryReviews,2) Response.Write ("

") For j = 1 to aryReviews(3,i) Response.Write ("") Next Response.Write (" " & aryReviews(7,i) & " (" & FormatDateTime(aryReviews(9,i),1) & ")
") Response.Write ("Reviewer: " & aryReviews(4,i) & ", " & aryReviews(5,i) & ", " & aryReviews(6,i)) Response.Write ("

" & aryReviews(8,i) & "

") Next End If 'Finish off the reviews HTML Response.Write ("
") End Sub '-------------------------------------------------------------------- ' Sub ShowAddReview ' Description: Displays form to add a new review. ' Preconditions: ' - ProductID must be set before calling this method. '-------------------------------------------------------------------- Public Sub ShowAddReview If ProductID = "" Then Exit Sub Response.Write("" & _ "

User reviews

") If sUserMsg <> "" Then Response.Write ("
" & sUserMsg & "
") Response.Write ("Please, write your review below. All reviews will be reviewed for accuracy.") Response.Write("
") Response.Write("") Response.Write("" & _ "" & _ "" & _ "") Response.Write("" & _ "
Select rating:" & _ "
Name:
Location:
Country:
Review title:
Your review:
" & _ "") Response.Write("
") Response.Write( "
") Response.Write("
") Response.Write("
") End Sub '-------------------------------------------------------------------- ' Sub SaveReview ' Description: Saves a submitted review using DAL object. ' Preconditions: ' - ProductID must be set before calling this method. ' - A form with the right fields must have been sumbitted. '-------------------------------------------------------------------- Public Sub SaveReview Dim nSaveStatus If ProductID = "" Then Exit Sub objUserReviewDAL.userRating = Request.Form("userRating") objUserReviewDAL.userRating = Request.Form("userRating") objUserReviewDAL.userName = Trim(Request.Form("userName")) objUserReviewDAL.userLocation = Trim(Request.Form("userLocation")) objUserReviewDAL.userCountry = Trim(Request.Form("userCountry")) objUserReviewDAL.userLocation = Trim(Request.Form("userLocation")) objUserReviewDAL.reviewTitle = Trim(Request.Form("reviewTitle")) objUserReviewDAL.reviewText = Trim(Request.Form("reviewText")) objUserReviewDAL.ProductID = ProductID objUserReviewDAL.userID = Session("UserID") nSaveStatus = objUserReviewDAL.SaveReview If nSaveStatus < 0 Then If nSaveStatus = -10 Then sUserMsg = "
Sorry, some required fields were missing. Please complete the form and submit it again.

" Call ShowAddReview Else sUserMsg = "
Sorry, there was an error saving your review.
" Call ShowReviews End If Else sUserMsg = "
Thank you for your review!" & _ "
Your review should appear shortly.
" Call ShowReviews End If End Sub '-------------------------------------------------------------------- ' Function GetURLParams ' Description: Builds a string with the URL parameters that were ' passed to the current page. ' Returns: ' - String of the form "param1=value¶m2=value&" '-------------------------------------------------------------------- Private Function GetURLParams Dim sURLParams For each param in Request.QueryString sURLParams = sURLParams & param & "=" & request.QueryString(param) & "&" Next GetURLParams = sURLParams End Function End Class %> <% Sub ShowTop10Center If Application("ShowTop10Center") = 1 Then Call ShowTop10 End If End Sub Sub ShowTop10Right If Application("ShowTop10Right") = 1 Then Call ShowTop10Width End If End Sub Sub ShowTop10 'Display Top 10 List Dim oProdList set oProdList = New ProductList oProdList.ShowList set oProdList = nothing End Sub Sub ShowTop10Width 'Display Top 10 List Dim oProdList set oProdList = New ProductList oProdList.Width = "100%" oProdList.ShowList set oProdList = nothing End Sub Sub ShowReviews (sProdID) Dim sFunction Dim objUserReviewUI sFunction = Request("Review") If sProdID = "" Then Exit Sub If Application("UserReviews") <> 1 Then Exit Sub 'Check that the scripting engine supports classes If ScriptEngineMajorVersion < 5 Then Exit Sub Select Case sFunction Case "": Set objUserReviewUI = New UserReviewUI objUserReviewUI.ProductID = sProdID objUserReviewUI.ShowReviews Set objUserReviewUI = nothing Case "Add": Set objUserReviewUI = New UserReviewUI objUserReviewUI.ProductID = sProdID objUserReviewUI.ShowAddReview Set objUserReviewUI = nothing Case "Save": Set objUserReviewUI = New UserReviewUI objUserReviewUI.ProductID = sProdID objUserReviewUI.SaveReview Set objUserReviewUI = nothing End Select End Sub '====================== 'Empty function shells: '====================== 'Sub ShowTop10Center 'End Sub 'Sub ShowTop10Right 'End Sub 'Sub ShowTop10 'End Sub 'Sub ShowReviews (sProdID) 'End Sub %> <% '======================================================================== ' Extract some fundamental variables used later on '======================================================================== ' New order status. Set here to the desired status Id: CONST N_BILLINGSTATUS_NEWORDER = 0 'Billing status for new orders CONST N_STATUS_NEWORDER = 0 'Order status for new orders Dim CartID, UserID 'Extract Cart ID from session, Query String or Form if not available (some SSL) If Session("CartID") <> "" Then CartID = Session("CartID") elseif Request.QueryString("CartID") <> "" Then CartID = Request.QueryString("CartID") Session("CartID") = CartID 'Save in the session else CartID = Request.Form("CartID") End If 'Extract UserID from session, Query String or Form if not available If Session("UserID") <> "" Then UserID = Session("UserID") elseif Request.QueryString("UserID") <> "" Then UserID = Request.QueryString("UserID") else UserID = Request.Form("UserID") End If 'If the Session UserID is different to the one in the querystring then take the one from the 'URL and update the Session variable and the variable UserID. 'This should only happen during checkout on a SSL connection if the ASP application is different 'i.e. using a shared certificate. If Session("UserID") <> Request.QueryString("UserID") AND Request.QueryString("UserID") <> "" Then Session("UserID") = Request.QueryString("UserID") UserID = Request.QueryString("UserID") End If '========================== START OF LIBRARY ============================= '========================================================================= ' Function: WritePriceOptions ' Writes the select box with the contents of the price ' options. '========================================================================= Function WritePriceOptions (ByVal PID,ByVal n) Dim Options, strSQL, strTemp 'Dim aryOptions () strTemp = "" strSQL = "SELECT PriceOptions.Id, PriceOptions.ProdId, PriceOptions.Description, PriceOptions.DifOrAbs, PriceOptions.Cost, Products.Taxable, Products.VATRate FROM PriceOptions, Products WHERE PriceOptions.ProdId ='" & PID & "' AND Products.ProdID = PriceOptions.ProdID" set Options = conn.Execute (strSQL) If NOT (Options.EOF AND Options.BOF) Then aryOptions = Options.GetRows Else set Options = nothing Exit Function End If Options.Close set Options = nothing If UBound(aryOptions,2) - LBound(aryOptions,2) >= 0 Then strTemp = "Select Option: " End If WritePriceOptions = strTemp End Function '========================================================================= ' Function: WritePriceOptions ' Writes the select box with the contents of the price ' options. '========================================================================= Function WritePriceOptionsPrintable (ByVal PID,ByVal n) Dim Options, strSQL, strTemp 'Dim aryOptions () strTemp = "" strSQL = "SELECT PriceOptions.Id, PriceOptions.ProdId, PriceOptions.Description, PriceOptions.DifOrAbs, PriceOptions.Cost, Products.Taxable, Products.VATRate FROM PriceOptions, Products WHERE PriceOptions.ProdId ='" & PID & "' AND Products.ProdID = PriceOptions.ProdID" set Options = conn.Execute (strSQL) If NOT (Options.EOF AND Options.BOF) Then aryOptions = Options.GetRows Else set Options = nothing Exit Function End If Options.Close set Options = nothing If UBound(aryOptions,2) - LBound(aryOptions,2) >= 0 Then strTemp = "Options: " For j = LBound(aryOptions,2) to UBound(aryOptions,2) 'Build string for price difference options If aryOptions(3,j) = 0 AND aryOptions(4,j) > 0 Then strAddDisc = "+" If aryOptions(3,j) = 0 AND aryOptions(4,j) < 0 Then strAddDisc = "-" strTemp = strTemp & "
  • " & aryOptions(2,j) If CStr(aryOptions(4,j)) <> "" AND CStr(aryOptions(4,j)) <> "0" Then strTemp = strTemp & " (" & strAddDisc & FormatDefCurr (FormatPrice(Abs(aryOptions(4,j)), aryOptions(6,j), aryOptions(5,j))) & ")" & vbCrLf End If strAddDisc = null Next strTemp = strTemp & "
    " End If WritePriceOptionsPrintable = strTemp End Function '========================================================================= ' Function: UnitPrs ' Returns units description. Currently only 1 is used '========================================================================= Function UnitPrs (cod) if cod = 1 Then UnitPrs = "Unit/s" if cod = 2 Then UnitPrs = "gr." if cod = 3 Then UnitPrs = "Kg." End Function '========================================================================= ' Function: CutRFWord ' Trim and cut to nlength craracters max the Request.Form(name) passed. '========================================================================= Function CutRFWord (name, nlength) Dim sTmp sTmp = Left(Trim(Request.Form(name)),nlength) If sTmp <> "" Then CutRFWord = sTmp Else CutRFWord = Null End If End Function '========================================================================= ' Function: ProdName ' Returns the name of a product with id cod '========================================================================= Function ProdName (cod) Dim rs, sql Set rs = Server.CreateObject("ADODB.Recordset") sql= "SELECT Name FROM products WHERE ProdID = '" & cod & "'" rs.Open sql,Conn, adOpenStatic, adLockOptimistic If rs.EOF AND rs.BOF Then ProdName = "Product deleted" else ProdName = rs("Name") End If rs.Close set rs = nothing End Function '========================================================================= ' Function: DeleteCart ' Deletes cart with ID IDCart '========================================================================= Function DeleteCart (IDCart) Dim rs, sql sql= "DELETE FROM Carts WHERE CartID = '" & IDCart & "'" set rs = Conn.Execute(sql) set rs = nothing End Function '========================================================================= ' Function: CreateOrder ' Creates order from cart with ID = IDCart in the orders/orderlines tables 'Uses from form: 'TotalTax: Total taxes 'ShipCost: Shipping costr 'e-mail: Email address 'Password: Password 'Billing details 'Name: Customer's Name 'Surname: Customer's Surname 'Company: Customer's Company name 'Address: Customer's Address part 1 'Address2: Customer's Address part 2 'CP: Customer's Post Code/ZIP 'Town: Customer's City/Town 'Province: Customer's State or Province 'Country: Customer's Country 'Telephone: Customer's Telephone number 'mailme: Is customer subscribing to receive news and notifications? (True/False) 'rememberme:Does customer want to be logged in automatically next time? (True/False) 'Shipping/Recepient details 'DName: Ship to Name 'DAddress: Ship to Address part 1 'DAddress2: Ship to Address part 2 'DCompany: Ship to Company 'DCP: Ship to Post Code/ZIP 'DTown: Ship to City/Town 'DProvince: Ship to State or Province 'DTelephone:Ship to Telephone number 'DCountry: Ship to Country ' 'payment: Payment type (VISA,COD, etc) 'CCOwner Name on Credit Card 'CCNumber: Credit Card Number 'CCExpDateMonth: Credit Card Expiration date month 'CCExpDateYear: Credit Card Expiration date year 'CCIssueNumber: Credit Card Issue Number 'CCCVV: Credit Card verification number 'TaxId: Tax code (Tax ID) (eg VAT number) 'strUPS: String returned by UPS real time calculation module ' 'Comments: Customer order comments. 'Uses variables from prochkoutend.asp: 'PriceT: Products total cost 'Taxes: Order tax 'TotalTax: Tax rate 'ShipCost: Shipping cost applied 'PriceTG: Order total 'WeightT: Total products weight '========================================================================= Function CreateOrder (IDCart) Dim rs, rsh, rsu, rsl, rsoid Dim sql Dim NewUSer Dim OrderID 'Get cart Set rs = Server.CreateObject("ADODB.Recordset") sql= "SELECT Carts.*, Products.Name, PriceOptions.Description As PODescription " & _ "FROM (Carts INNER JOIN Products ON Carts.ProdID = Products.ProdID) " & _ "LEFT OUTER JOIN PriceOptions ON Carts.PriceOption = PriceOptions.id " & _ "WHERE CartID = '" & IDCart & "'" rs.Open sql, Conn, adOpenStatic, adLockOptimistic 'Orders Headers DB: rsh 'Note: We query an impossible record to correct a possible 'wrong behaviour with Microsoft's DB drivers Set rsh = Server.CreateObject("ADODB.Recordset") rsh.Open "SELECT * from Orders WHERE (0 = 1)", Conn, adOpenKeySet, adLockOptimistic 'OrderLines DB: rsl Set rsl = Server.CreateObject("ADODB.Recordset") rsl.Open "SELECT * from Orderlines WHERE (0 = 1)", Conn, adOpenStatic, adLockOptimistic 'User Data: rsu Set rsu = Server.CreateObject("ADODB.Recordset") rsu.Open "SELECT * from Users WHERE UserID ='" & UserID & "'", Conn, adOpenStatic, adLockOptimistic If rsu.EOF AND rsu.BOF Then 'If no data found create a new one NewUSer = True rsu.Close rsu.Open "SELECT * from Users WHERE (1=0)", Conn, adOpenStatic, adLockOptimistic Else NewUser = False End If If NewUSer then rsu.AddNew rsu("UserID") = UserID If Request("Company") <> "" Then rsu("Company") = CutRFWord("Company",50) Else rsu("Company") = Null End If rsu("Name") = CutRFWord("Name",50) rsu("Surname") = CutRFWord("Surname",50) rsu("Address") = CutRFWord("Address",100) rsu("Address2") = CutRFWord("Address2",100) rsu("CP") = CutRFWord("CP",10) rsu("City") = CutRFWord("Town",50) If Trim(Request.Form("Province")) <> "" Then rsu("Province") = CutRFWord("Province",50) rsu("Country") = CutRFWord("Country",20) If Trim(Request.Form("Telephone")) <> "" Then rsu("Phone") = CutRFWord("Telephone",50) If Request.Form("e-mail") <> "" Then rsu("mail") = CutRFWord("e-mail",100) If Request.Form("mailme") = "yes" Then rsu("mailme") = 1 else rsu("mailme") = 0 End If else rsu("mailme") = 0 End If If Request.Form("rememberme") = "yes" Then rsu("rememberme") = 1 Else rsu("rememberme") = 0 End If rsu("Date") = Now 'If is a new user and has chosen a password (error if not) and is not logged (extra check) then 'use the suggested password If NewUser AND (NOT Session("Logged")) AND Request.Form("Password") <> "" Then rsu("pwd") = Request.Form("Password") End If ' If IsNull(rsu("pwd")) AND Session("uPwd")<> "" Then rsu("pwd") = Session("uPwd") rsu("LastVisit") = Date Session("DateUpdated") = True rsu.Update rsu.Close set rsu = nothing rsh.AddNew rsh("UserID") = UserID rsh("CartID") = CartID rsh("Date") = Now 'Formatdatetime(now(),2) 'Customer details If Trim(Request.Form("Company")) <> "" Then rsh("Company") = CutRFWord("Company",100) rsh("Name") = CutRFWord("Name",50) rsh("Surname") = CutRFWord("Surname",50) rsh("Address") = CutRFWord("Address",100) rsh("Address2") = CutRFWord("Address2",100) rsh("CP") = CutRFWord("CP",10) rsh("City") = CutRFWord("Town",50) if Request.Form("Province") <> "" Then rsh("Province") = CutRFWord("Province",50) If Request.Form("Telephone") <> "" Then rsh("Phone") = CutRFWord("Telephone",50) rsh("mail") = CutRFWord("e-mail",100) rsh("Country") = CutRFWord("Country",20) 'Delivery Details If Trim(Request.Form("DName")) <> "" Then rsh("DName") = CutRFWord("DName",100) If Trim(Request.Form("DAddress")) <> "" Then rsh("DAddress") = CutRFWord("DAddress",100) If Trim(Request.Form("DAddress2")) <> "" Then rsh("DAddress2") = CutRFWord("DAddress2",100) If Trim(Request.Form("DCompany")) <> "" Then rsh("DCompany") = CutRFWord("DCompany",100) If Trim(Request.Form("DCP")) <> "" Then rsh("DCP") = CutRFWord("DCP",10) If Trim(Request.Form("DTown")) <> "" Then rsh("DCity") = CutRFWord("DTown",50) If Trim(Request.Form("DProvince")) <> "" Then rsh("DProvince") = CutRFWord("DProvince",50) If Trim(Request.Form("DTelephone")) <> "" Then rsh("DPhone") = CutRFWord("DTelephone",50) If Trim(Request.Form("DCountry")) <> "" Then rsh("DCountry") = CutRFWord("DCountry",20) 'Costs rsh("SubTotal") = CDbl(PriceT) rsh("Taxes") = Taxes rsh("TotalTax") = TotalTax rsh("Delivery") = ShipCost rsh("Total") = CDbl(PriceTG) If CStr(WeightT) <> "" Then rsh("Weight") = CDbl(WeightT) else rsh("Weight") = 0 End If 'Store user discount value. rsh("UserDiscount") = nUrDiscountTotal '==================================== ' Order status and billing status ' Change the default values at the top '==================================== ' Set the status of new orders. rsh("Status") = N_STATUS_NEWORDER ' Set the billing status of new orders. rsh("BillingStatus") = N_BILLINGSTATUS_NEWORDER 'Payment method rsh("PaymentMode") = CutRFWord("payment",50) 'Credit card details stored if there is an owner name (CCOwner). If Request.Form("CCOwner") <> "" Then rsh("CCOwner") = CutRFWord("CCOwner",100) 'Remove spaces and "-". Dim sEncCCNumber sEncCCNumber = Replace(Replace(CutRFWord("CCNumber",40)," ",""),"-","") 'Encrypt and encode into HEX string to be safely stored sEncCCNumber = EncryptAndEncode(sEncCCNumber) 'rsh("CCNumber") = Replace(Replace(CutRFWord("CCNumber",40)," ",""),"-","") rsh("CCNumber") = sEncCCNumber 'Store the encrypted and encoded in Hex string CC number rsh("CCExpDate") = EncryptAndEncode(CutRFWord("CCExpDateMonth",2) & "/" & Right(Request.Form("CCExpDateYear"),2)) If Request.Form("CCIssueNumber") <> "" Then rsh("CCIssueNumber") = CutRFWord("CCIssueNumber",10) End If 'Get CVV number (from back of some cards). Cut to 7 characters. If CutRFWord("CCCVV",7) <> "" Then rsh("CCCVV") = CutRFWord("CCCVV",7) End If End If 'UPS returned values. Store here if adding another external company system. If Request.Form("strUPS") <> "" Then rsh("Shipping") = CutRFWord("strUPS",50) End If 'VAT number used in European Union to allow tax exemption for companies If Request.Form("TaxId") <> "" Then rsh("TaxID") = CutRFWord("TaxId",100) End If 'Transaction values return in real time payment processing like Authorize.Net. If strTrans <> "" Then rsh("TransactionData") = Left(strTrans,150) End If 'User comments If Trim(Request.Form("Comments")) <> "" Then rsh("Comments") = Request.Form("Comments") 'User IP address stored as security meassure. rsh("RemoteIP") = LEFT(Request.ServerVariables("REMOTE_ADDR"),15) 'Save details rsh.Update 'Obtain the order Id generated automatically by the database OrderID = rsh("Id") rsh.Close set rsh = nothing 'If the Order id wasn't retrieved correctly, attempt to query the record using the combination 'of Cart Id and User Id. This code should not get to be executed in a normal installation!. If CStr(orderID) = "" Then set rsoid = conn.Execute ("SELECT Id FROM orders WHERE UserID = '" & UserID & "' AND CartId = '" & CartID & "' ORDER BY Id DESC") If rsoid.EOF and rsoid.BOF Then set rsoid = nothing %> Fatal Error occurred, please contact shop administrator. Your order ID could not be retrieved

    [an error occurred while processing this directive] <% 'Close and destroy connection Call CloseCnx(conn) %> <% Response.End else OrderID = rsoid("Id") End If rsoid.Close set rsoid = nothing End If Do while NOT rs.eof rsl.AddNew rsl("OrderID") = OrderID rsl("ProdID") = rs("ProdID") rsl("Price") = rs("Price") rsl("Qtty") = rs("Qtty") rsl("Units") = rs("Units") If rs("Option1") <> "" AND rs("Option1") <> vbNull Then rsl("Option1") = rs("Option1") End If If rs("Option2") <> "" AND rs("Option2") <> vbNull Then rsl("Option2") = rs("Option2") End If If rs("PriceOption") <> "" AND rs("PriceOption") <> vbNull Then rsl("PriceOption") = rs("PriceOption") End If rsl("ProdName") = rs("Name") 'Save the product Name (in case it changes) rsl("PriceOptionDesc") = rs("PODescription") 'Save the Price Option Name (in case it changes) rsl.Update 'Register order line in Historic table RegPurch rs("ProdID"), rs("CatID"), UserID 'Update teh stock level accordingly DecreaseStock rs("ProdId"), rs("Qtty") rs.movenext Loop rs.Close rsl.Close set rs = nothing set rsl = nothing 'If it's a new user then set basic info in the Session If NOT Session("Logged") Then Session("Name") = Request.Form("Name") Session("Surname") = Request.Form("Surname") Session("Mail") = Request.Form("E-Mail") Session("Country") = Request.Form("Country") Session("uPwd") = Request.Form("Password") Session("UserDiscount") = 0 'Set new users discount to 0 as default. End If 'Log the user in automatically Session("Logged") = True 'Return the order Id CreateOrder = OrderID End Function '========================================================================= ' Function: RegPurch ' Registers purchase in the customer's purchase history '========================================================================= Function RegPurch (PID, CID, UID) Dim reg, sql Set reg = Server.CreateObject("ADODB.Recordset") sql= "SELECT * FROM Historic WHERE UserID = '" & UID & "' AND ProdID = '" & PID & "'" reg.Open sql,Conn, adOpenStatic, adLockOptimistic If reg.EOF AND reg.BOF Then 'reg.recordcount = 0 reg.AddNew reg("UserID")= UID reg("ProdID")= PID reg("CatID")= CID reg("Qtty")= 1 reg("Date") = Now reg.Update Else TotalItms = reg("Qtty") reg("Qtty") = TotalItms + 1 reg("Date") = Now reg.Update End If reg.Close set reg = nothing End Function '========================================================================= ' Function: MoveCart ' FUNCTION INCLUDED FOR BACKWARDS COMPATIBILITY: It simply calls CreateOrder if 'an old version of procchkoutend calls MoveCart. '========================================================================= Function MoveCart (nIDCart) MoveCart = CreateOrder (nIDCart) End Function '========================================================================= ' Function: DecreaseStock (PID, Qtty) ' Decreases the Stock for Product Id PID is Stock control is active '========================================================================= Function DecreaseStock (PID, Qtty) Dim stock, sql If shop_StockControl Then Set stock = Server.CreateObject("ADODB.Recordset") sql= "UPDATE Products SET Stock = Stock - " & Qtty & " WHERE ProdID = '" & PID & "'" set stock = conn.Execute(sql) set stock = nothing End If End Function '========================================================================= ' Function: CheckStock ' Checks that all products in cart are in stock. ' Returns True if all products are in stock and False if not '========================================================================= Function CheckStock Dim strSQL, CartRs 'Only check if the stock control is on If shop_StockControl Then strSQL = "SELECT Products.ProdId FROM Carts, Products where Carts.ProdId = Products.ProdId AND Stock < Qtty AND Carts.CartID = '" & CartID & "'" 'Response.Write strSQL Set CartRs = Server.CreateObject("ADODB.Recordset") set CartRs = conn.Execute(strSQL) If CartRs.EOF AND CartRs.BOF Then 'All products are in stock CheckStock = True Else 'Some products are not in stock CheckStock = False End If CartRs.Close set CartRs = nothing else CheckStock = True End If End Function %> <% Function GenerateUserId 'Generates a user Id that is not already in the database. Dim sUserId, IsValidNew IsValidNew = False sUserId = "" While NOT IsValidNew 'Generate a new Id (10 digits = 22,809,600,000,000 possible combinations Randomize sUserId = chr (int( 20 * Rnd +65 )) & _ chr (int( 20 * Rnd +65 )) & _ int ( 9 * Rnd + 1) & _ chr (int( 20 * Rnd +65 )) & _ chr (int( 20 * Rnd +65 )) & _ chr (int( 20 * Rnd +65 )) & _ int ( 9 * Rnd + 1) & _ chr (int( 20 * Rnd +65 )) & _ chr (int( 20 * Rnd +65 )) & _ chr (int( 20 * Rnd +65 )) 'Query how many times the UserId is in teh database (should be 0 or 1) sql = "SELECT COUNT(*) FROM Users Where UserId = '" & sUserId & "'" Set Rs = conn.Execute (sql) If NOT (rs.EOF and rs.BOF) Then If Rs(0) = 0 Then 'Does not exist IsValidNew = True Else 'Already exists! IsValidNew = False End If Else 'If if fails to perform the operation suppose it is correct 'this is to avoid an infinite loop IsValidNew = True End If 'Close an clean up recordset rs.Close set rs = nothing Wend GenerateUserId = sUserId End Function Function CheckEmailDB (sEmail) Dim sSQL, RsEmail, bResult bResult = False sSQL = "SELECT Mail From Users where Mail = '" & Trim(sEmail) & "'" Set RsEmail = Server.CreateObject("ADODB.Recordset") Set RsEmail = conn.execute(sSQL) If RsEmail.EOF AND RsEmail.BOF Then 'E-mail does not exist in the database bResult = False Else 'E-mail does already exist" bResult = True RsEmail.Close End If set RsEmail = nothing CheckEmailDB = bResult End Function Function CheckUserId (sUserId) 'Returns True if the User Id does not exist in the database 'Returns True if the User Id exists in the database Dim sSQL, RsUser, bResult bResult = False sSQL = "SELECT UserID From Users where UserID = '" & Trim(sUserId) & "'" Set RsUser = Server.CreateObject("ADODB.Recordset") Set RsUser = conn.execute(sSQL) If RsUser.EOF AND RsUser.BOF Then 'UserID does not exist in the database bResult = False Else 'UserID does already exist" bResult = True RsUser.Close End If set RsUser = nothing CheckUserId = bResult End Function Function CheckUserEmail (sEmail) 'Returns True if the User email does not exist in the database 'Returns True if the User email exists in the database Dim sSQL, RsUser, bResult bResult = False sSQL = "SELECT mail From Users where mail = '" & Trim(sEmail) & "'" Set RsUser = Server.CreateObject("ADODB.Recordset") Set RsUser = conn.execute(sSQL) If RsUser.EOF AND RsUser.BOF Then 'UserID does not exist in the database bResult = False Else 'UserID does already exist" bResult = True RsUser.Close End If set RsUser = nothing CheckUserEmail = bResult End Function 'Updates a cart with a new User Id Sub UpdateCartUserID (sUserID, sCartID) Dim Rs, sSQL sSQL = "UPDATE Carts SET UserID = '" & sUserID & "' WHERE CartID = '" & sCartID & "'" Set Rs = Server.CreateObject("ADODB.Recordset") set Rs = conn.execute(sSQL) set Rs = nothing End Sub 'Updates "My List" with a new User Id Sub UpdateMyListUserID (sOldUserID, sNewUserID) Dim Rs, sSQL sSQL = "UPDATE CommonList SET UserID = '" & sNewUserID & "' WHERE UserID = '" & sOldUserID & "'" Set Rs = Server.CreateObject("ADODB.Recordset") set Rs = conn.execute(sSQL) set Rs = nothing End Sub Sub ResetUser 'Reset User ID on Session and create a new one, reset user details as well. 'Write the new User ID to a cookie 'It also updates the cart items with the new UserID. Dim oUserID 'Old user ID Dim Rs oUserID = Session("UserID") 'Obtain User Id from the cookie Session("Logged") = False 'Log user out Session("UserID") = GenerateUserId 'Generate new User Id Session("Cookie")= 0 'This will force to write a cookie with the new id. 'Reset user information Session("Name") = Null Session("Surname") = Null Session("Mail") = Null Session("Country") = Null Session("UserDiscount") = 0 If Application("Tax_Model") = "EU" Then Session("TaxID") = Null On Error Resume Next 'Update the cart with the new UserID (in case the user had added something) Set Rs = Server.CreateObject("ADODB.Recordset") set Rs = conn.execute("UPDATE Carts SET UserID = '" & Session("UserID") & "' WHERE CartID = '" & Session("CartID") & "'") set Rs = nothing End Sub Sub WriteUserIdCookie (sUserId) 'Writes the UserID Cookie Response.Cookies("UserID") = sUserId 'Sets expiry date Response.Cookies("UserID").Expires = Date + 180 '6 months to expire (6*30 = 180 days) 'Example of fixed date: "1 Dec 1999" 'Saves the cookie state as "Written to client" Session("Cookie") = 1 End Sub Sub UpdateLastVisit (sUserId) ' Updates the LastVisit field in the database Dim Rs, sql, dtDate, strDateSep ' If NOT Session("DateUpdated") Then If shop_DB = "SQL" Then strDateSep = "'" 'MS SQL Server 'Get the date in an international format YYYY-MM-DD recognised by SQL Server dtDate = Year(Date) & "-" & Month(Date) & "-" & Day(Date) Else strDateSep = "#" 'MS Access 'Use with Access: It must be in US format MM/DD/YY regardless of local settings. dtDate = Month(Date) & "/" & Day(Date) & "/" & Year(Date) End If sql = "UPDATE Users SET LastVisit = " & strDateSep & dtdate & strDateSep & " WHERE UserID = '" & sUserId & "'" conn.execute sql 'Update this variable so we don't update the date again during this session Session("DateUpdated") = True ' End If End Sub Function CleanLoginPwd (sText) ' Cleans a text to be used as login or password to avoid SQL injection attacks. Dim sCleanText sCleanText = Replace(sText, "'", "") sCleanText = Replace(sCleanText, """", "") sCleanText = Replace(sCleanText, " ", "") sCleanText = Trim(sCleanText) CleanLoginPwd = sCleanText End Function %> <% 'If user says the is not the user suggested then reset details and create new id If Request.Querystring("resetuser") = "yes" Then Call ResetUser 'Set user cookie and expiry date 'If the cookie hasn't been set do so. If Session("Cookie") = 0 Then Response.Cookies("UserID") = Session("UserID") Response.Cookies("UserID").Expires = Date + 180 '6 months to expire 'Example of fixed date: "1 Dec 1999" 'Refer to VBScript and ASP documentation Session("Cookie") = 1 'If the cookie had been set extend its expiration date and create welcome back message Else UserID = Session("UserID") 'Refresh the cookie so that it doesn't expire Response.Cookies("UserID").Expires = Date + 180 '6 months to expire 'Example of fixed date: "1 Dec 1999" If Session("Name") <> "" Then WMsg =" back " & Session("Name") & "!" Else WMsg =" back!" End If End If %> <%= shop_Title %> <% '====================================================================================== ' File: head.inc ' Description: This file produces the HTML for the definition of the top of all the ' shop pages. It also includes a call to the include file that creates ' the left hand side navigation bar leftinc.asp and until the creation of ' the cell that contains the main body of the pages. '====================================================================================== ' Initialise cat variable with the contents of Request("cat"). This holds current ' category/section Dim strNav If Request("cat") <> "" Then strNav = "cat=" & Request("cat") & "&path=" & Request("path") %>
     

    <%= LogoURL %>

    WELCOME to the Online Bookstore! All items can be accessed using the left side bar.

    FEBRUARY SPECIAL:
    "COSMIC CONSCIOUSNESS: Do-It-Yourself Manual" eBook 
    by Rama Demetrius Dyushambee, DD 
    AKA: INspector Out Rageous, The Cosmic Detective



    BOOKSELLERS LOG IN to order at  special incentive rates!

    		  

    Sorry, your browser doesn't support Java(tm).

    AUTHORS TRACK STATUS 
    of Star Quest orders from booksellers and distributors.

     

     

     

    This site is provided by Star Quest Publishing and makes no representations of any kind, expressed or implied including but not limited to content accuracy, fitness for any purpose or product endorsement for publications listed. Star Quest Publishing and its subsidiaries and agents will not be held liable for any damages of any kind arising from the use or misuse of this site, the contents, products, or information including but not limited to direct, indirect, incidental punitive and consequential damages. Any material directly or indirectly referenced or contained on this site is not intended to provide medical advice nor is it intended as a substitute for any treatment prescribed by your healthcare professional. Before engaging in any exercise or suggestion, including those that may be in this website, consult your health care professional first.
    		<% If NOT Session("Logged") Then %>
    Authors & Booksellers Login:
    E-mail:
    ">
    Password:

    Not registered yet?
    Forgot your password?
    <% End If %> <% '============================================================== ' inc\show_featured.asp ' Shows a random n products from the featured products list. ' Copyright © QuadComm, Inc. 2000-2002 '============================================================== 'Get how many featured products are shown Dim SHOW_FEATURED_MAX If IsNumeric(Application("FeatProdsNumber")) Then SHOW_FEATURED_MAX = CInt(Application("FeatProdsNumber")) Else SHOW_FEATURED_MAX = 2 'Default to 2 End If '================================================================ ' ShowFeaturedProds (nMaxProds) ' Shows a number of featured products. ' nMaxProds: Maximum number of featured products to display '================================================================ Sub ShowFeaturedProds (nMaxProds) Dim strFeatured, strsql, strFeat Dim i, j, nMaxLoops nMaxLoops = 50 'Defines the maximum number of times the algorithm will try to 'get a new random product. Used to avoid cases where we want 'more products than unique products id's are defined from the 'application settings. When all the product ids are unique this 'is not a problem as the max number is modified accordingly. j = 0 'Loop count strFeatured = Trim(Application("Featured")) If strFeatured = "" Then strFeatured = Null If NOT IsNull(strFeatured) Then Dim aryFeat, nFeatNum, nFeatID, Rs Set Rs = Server.CreateObject("ADODB.Recordset") aryFeat = Split(Replace(strFeatured," ",""),",") nFeatNum = UBound(aryFeat) - LBound(aryFeat) 'Make sure that we are not trying to display more products 'than there are available If nMaxProds > nFeatNum + 1 then nMaxProds = nFeatNum + 1 For i = 1 to nMaxProds Randomize nFeatID = Int((UBound(aryFeat) + 1) * Rnd ) 'Check that the product is not already im the list If Instr(strFeat,aryFeat(nFeatID)) = 0 Then If i < 2 Then strFeat = "'" & aryFeat(nFeatID) & "'" Else strFeat = strFeat & ", '" & aryFeat(nFeatID) & "'" End If Else 'If the product was already selected then generate a new one again 'by decreasing the counter i i = i - 1 End If j = j + 1 'Increase loop count If j > nMaxLoops Then Exit For 'If loop limit has been reached get out of the loop! Next strsql = "SELECT Products.*, Categories.CatID As MainCatID FROM Products " & _ "INNER JOIN " & _ "(Categories INNER JOIN ProductToCategory ON Categories.CatID = ProductToCategory.CatID) " & _ "ON Products.ProdID = ProductToCategory.ProdID " & _ "WHERE (Products.Show = 1 AND Categories.Show = 1) AND Products.ProdId IN (" & strfeat & ") AND ProductToCategory.IsMain = 1 AND (Products.Show = 1 AND Categories.Show = 1)" If shop_StockControl Then strsql = strsql & " AND Stock > 0" End If set Rs = conn.Execute (strsql) While NOT Rs.EOF PrintFeatProd Rs Rs.movenext Wend Rs.Close set Rs = nothing End If End Sub Sub PrintFeatProd (Rs) Dim str, ProdId, CatID, Name, Thumbnail, Offer, Price, strOptionLbl, DefCurName, SecCurName Dim nActualCost, nListCost, bIsOffer Dim options ProdId = rs("ProdID") CatID = rs("MainCatID") Name = rs("Name") Thumbnail = rs("Thumbnail") Offer = rs("Offer") Price = rs("Price") nTaxable = rs("Taxable") nVATRate = rs("VATRate") 'Load the prices into variables If Offer <> "" Then 'Product on sale nActualCost = Offer 'Actual price is the offer price nListCost = Price 'List price (before discount) bIsOffer = True 'Product on special offer (used for formatting) Else 'Normal price nActualCost = Price 'Actualprice is the list price nListCost = nActualCost 'Actual and list price are the same bIsOffer = False 'Product is not on special offer (used for formatting) End If ' FormatDefCurr(FormatPrice(nActualCost, nVATRate, nTaxable)) %>"> "> "> ">
    Featured Product
    "><%= Name %>
    <% If Thumbnail <> "" Then 'If we have a picture display it Response.Write "" 'If the picture is not defined show alternative image/text defined in /head.inc Else Response.Write (LineLogoURL) End If %>
    <% 'If this is a special offer If bIsOffer Then %> <%= FormatDefCurr(FormatPrice(nActualCost, nVATRate, nTaxable)) %>!
    (was <%= FormatDefCurr(FormatPrice(nListCost, nVATRate, nTaxable)) %>)
    You save: <%= FormatNumber((1-(nActualCost/nListCost))*100,0) %>% <% 'If there is a secondary currency defined display it If shop_SecCurName <> "" Then %>
    (<%= FormatSecCurr(FormatPrice(nActualCost, nVATRate, nTaxable)) %>)
    <% End If Else 'Not an offer %> <%= FormatDefCurr(FormatPrice(nActualCost, nVATRate, nTaxable)) %> <% If shop_SecCurName<> "" Then %>
    (<%= FormatSecCurr(FormatPrice(nActualCost, nVATRate, nTaxable)) %>) <% End If End If 'If Offer 'Display Options if available 'Option 1: str = rs ("OptionsV1") If str <> "" Then strOptionLbl = rs ("OptionsD1") 'Split the options into an array options = split(str,",") Response.Write "
    " & strOptionLbl & ": " bFoundOpt = True End If 'Option 2: str = rs ("OptionsV2") If str <> "" Then strOptionLbl = rs ("OptionsD2") 'Split the options into an array options = split(str,",") Response.Write "
    " & strOptionLbl & ": " bFoundOpt = True End If If bFoundOpt Then Response.Write("
    ") bFoundOpt = False End If strPO = WritePriceOptions (ProdId,1) If strPO <> "" Then Response.Write(Replace(strPO & "
    ","Select Option: ","")) End If strPO = null %>
    <% End Sub 'Display n (SHOW_FEATURED_MAX) products in column: 'On Error Resume Next Call ShowFeaturedProds (SHOW_FEATURED_MAX) If Err.Number <> 0 Then Response.Write "Featured products unavailable" End If %> <% '================================================= 'ADDON: Shows Top 10 Sold Products. Add-on required! Call ShowTop10Right '================================================= %>

    Star Quest Publishing © 2003-2007       www.StarQuestPublishing.com       Email: info@StarQuestPublishing.com      
    <% 'Close and destroy connection Call CloseCnx(conn) %>