<% '**************************************************************************** ' Diagnostic Tool for VP-ASP Shopping Cart ' Can be used to test database access and mail access ' Version 6.50 ' 30 May 2006 '***************************************************************************** Const LangTestHeader="VP-ASP Diagnostics 6.50" const LangDatabaseTest="Test Database" const LangMailTest="Test Mail" Const LangTestConfig="Test your current or new configuration" Const LangTestChanges="Changes are not automatically updated in shop$config.asp" 'Const LangTestMailfail=" is probably not installed on this system.
You can change the mail system used by logging into the admin and changing xemailtype
to a component that is installed on your server." Const LangTestMailfail=" is probably not installed on this system." Const LangTestMailInfo="This is test from VP-ASP using " Const LangTestWriteFail="FAIL" Const LangTestReadFail="FAIL" Const LangTestWriteOK="PASS!" Const LangTestVerify="Please ensure the database is at the physical location shown below." Const LangTestPerFail="FAIL" Const LangTestRead="Database Read" Const LangTestWrite="Database Write" Const LangTestReadOK="PASS!" Const LangTestDirectory="Verify that the database is in a folder that has both read and write access.
For more information on database permissions, please see our website.
" Const LangTestPer="Database Permissions" Const LangTestPerOK="PASS!" Const LangTestReadFAQ="Read the FAQ on our web site regarding permission for the anonymous user IUSR" Const LangTestSummary="" Const LangTestFileRead="Test file read" ' dim sAction Dim strbody Dim strSubject Dim strFrom dim strFromemail dim currentURL Dim Fieldnames(30) Dim Fieldvalues(30) Dim fieldname Dim Fieldvalue Dim Fieldcount Dim Serrors Dim curTest Dim PrevTest Dim errorCount dim my_system dim my_from dim my_fromAddress dim my_subject dim my_to dim my_toAddress dim body dim htmlformat Dim Msg Dim mailtype Dim mailer Dim Emailformat dim tablerowcolor dim initapp ' 'If Getconfig("init")="No" then ' SetConfig "init","" 'end if sAction=request("dbshop") if saction<>"" then saction="DBSHOP" else saction=request("dbcustom") if saction<>"" then sACTION="DBCUSTOM" else saction=request("mail") if saction<>"" then sACTION="MAIL" else saction=request("Fileread") if saction<>"" then sACTION="READFILE" end if end if end if end if currentURL="diag_dbtest.asp" dbtable="tbluser" dbfield="flddatabase" GetFieldNames GetFieldvalues if saction="" then specPageHeader DisplayForm specPageTrailer else ProcessForm WriteDiagnosticHeader RunTests WriteDiagnosticTrailer end if Sub DisplayForm %>
method=POST> <% end sub Sub FormatRow (fieldlabel,fieldname, sRowColor) Response.Write("") end sub Sub ProcessForm dim strname dim strvalue For Each key in Request.Form strname = key strvalue = Request.Form(key) SetSess strname, strvalue 'debugwrite key & "=" & strvalue Next end sub ' Sub GetFieldnames Fieldnames(0)="xDatabase" Fieldnames(1)="xDblocation" Fieldnames(2)="xdatabasetype" Fieldnames(3)="xEmail" Fieldnames(4)="xEmailName" Fieldnames(5)="xEmailSubject" Fieldnames(6)="xEmailSystem" Fieldnames(7)="xEmailType" Fieldnames(8)="xOrdernumber" fieldcount=8 end sub ' Sub GetFieldvalues Dim strvalue strvalue=GetSess(fieldnames(0)) if strvalue="" then SetDefaultValues else for i = 0 to fieldcount fieldvalues(i)=Getsess(fieldnames(i)) next strbody=GetSess("body") end if end sub Sub SetDefaultValues Fieldvalues(0)=xdatabase Fieldvalues(1)=xdblocation Fieldvalues(2)=xdatabasetype 'Fieldvalues(3)=getconfig("xemail") 'Fieldvalues(4)=getconfig("xemailname") 'Fieldvalues(5)=getconfig("xemailsubject") 'Fieldvalues(6)=getconfig("xEmailsystem") 'Fieldvalues(7)=getconfig("xEmailType") Fieldvalues(8)=xordernumber end sub Sub RunTests ErrorCount=0 if saction="MAIL" then RunMailtests exit sub end if if saction="DBSHOP" then GetShopValues RunDatabaseTests exit sub end if if saction="DBCUSTOM" then GetCustomValues RunDatabaseTests exit sub end if if saction="READFILE" then RunFileReadTests exit sub end if end sub sub GetShopValues SetSess "db",xdatabase SetSess "dblocation",xdblocation SetSess "xdatabasetype", Ucase(xdatabasetype) end sub sub GetCustomValues SetSess "db",request("xdatabase") SetSess "dblocation",request("xdblocation") SetSess "xdatabasetype", Ucase(request("xdatabasetype")) end sub Sub RunDatabaseTests dim dbc dim testsql dim testrs dim rstemp Serrors="" setsess "diagnostic","Yes" 'Shopinit curTest="Database Open" Shopopendatabase_diag dbc, getsess("db"), xdatabasetype setsess "diagnostic","" on error resume next curTest=LangTestRead testsql = "select * from " & dbtable Set testrs = dbc.Execute(Testsql) fieldvalue=testrs(dbfield) if err.number > 0 then addError "" & LangTestReadFail & "" addError LangTestVerify CheckMicrosoftError dbc Adderror GetSess("dbc") AddError GetSess("Openerror") else addInfo LangTestReadOk end if testrs.close response.write "" curTest=LangTestWrite Set rstemp = Server.CreateObject("ADODB.Recordset") rstemp.open dbtable, dbc, 1, 3 rstemp.update rstemp(dbfield)="shopdbtest" rstemp.update If err.number > 0 then addError "" & LangTestWriteFail & "" addError LangTestDirectory AddError GetSess("Openerror") else If dbc.errors.count> 0 then addError "" & langtestwritefail & "" addError LangTestDirectory response.write "" AddError GetSess("Openerror") CheckMicrosoftError dbc else addInfo LangTestwriteOK end if end if response.write "" curTest=LangTestPer dim mysql mysql="select * from configuration" Set rstemp = Server.CreateObject("ADODB.RecordSet") rstemp.cursorlocation=aduseclient rstemp.cachesize=5 rstemp.Open MYSQL,dbc,adOpenKeyset,adLockReadOnly, adCmdText If err.number > 0 then addError "" & LangTestPerFail & "" addError LangTestReadFAQ else If dbc.errors.count> 0 then addError "" & LangTestWriteFail & "" addError LangTestVerify CheckMicrosoftError dbc else addInfo LangTestPerOK end if end if dbc.close set dbc=nothing 'curTest="Summary" 'if Errorcount=0 Then ' addinfo errorinfostart & LangTestSummary & errorinfoend 'end if end sub ' Sub addError (msg) if curtest<>PrevTest then Response.write "" & vbcrlf else Response.write "" & vbcrlf end if Response.write "" & vbcrlf errorcount=errorCount+1 PrevTest=CurTest end sub Sub addErrorCurrent (msg) if curtest<>PrevTest then Response.write "" & vbcrlf else Response.write "" & vbcrlf end if Response.write "" & vbcrlf errorcount=errorCount+1 PrevTest=CurTest end sub Sub addInfo (msg) if curtest<>PrevTest then Response.write "" & vbcrlf else Response.write "" & vbcrlf end if Response.write "" & vbcrlf PrevTest=CurTest end sub Sub addInfoCurrent (msg) if curtest<>PrevTest then Response.write "" & vbcrlf else Response.write "" & vbcrlf end if Response.write "" & vbcrlf PrevTest=CurTest end sub Sub WriteDiagnosticHeader specPageHeader 'Response.Write("

") 'Response.write largeinfofont & LangTestHeader & largeinfoend & "
" ''Response.Write(errorfontstart & sErrors & errorfontend & "
") End Sub ' Sub WriteDiagnosticTrailer Response.Write("
Test Your Database Connection
METHOD 1: Test using the settings in your shop$config.asp file.
 
METHOD 2: Test using your own settings. Fill out the form below with the settings you wish to test and click the button at the right to test.
<% FormatRow "Database Name","xdatabase", sRowColor %><% FormatRow "Database Location","xdblocation", sRowColor %>
Databse Type
 
 
Test Your Email
Can your site send email correctly? Click this button to test it.
Send test email to: ">
 
Test Your Permissions (Access Database Only)
Are your file permissions set up correctly so your database can be accessed correctly by VP-ASP? Click this button to check.
" & trim(fieldlabel) & "
  
 
  
" & curtest & "
" & msg & "
" & curtest & "
" & msg & "
" & curtest & "
" & msg & "
" & curtest & "
" & msg & "
") specPageTrailer End Sub ' Sub RunMailTests response.write "The following Email Components have been tested. The highlighted option is the one you have selected in your Configuration.

If this component says FAIL, you can change it by logging into your Administration and going to Setup > Merchant Details > xemailtype


" response.write "PLEASE NOTE: If a component below says PASS, it does not necessarily mean the email has sent successfully.
It just means that the email has been successfully passed from VP-ASP to your mailing component.
If the email doesn't arrive from there, you will need to speak to your host to find out why it is being lost between the mailing component and your mailing gateway.

" '**************************************************** ' Run tests with user supplied mail, if it fails try CDONTS '**************************************************** Dim description dim acount, i, mailtypes(8) mailtypes(0) = "CDONTS" mailtypes(1) = "CDOSYS" mailtypes(2) = "DUNDAS" mailtypes(3) = "ASPEMAIL" mailtypes(4) = "ASPMAIL" mailtypes(5) = "JMAIL" mailtypes(6) = "JMAIL43" mailtypes(7) = "OCXMAIL" mailtypes(8) = "SOFTART" for i = 0 to 8 htmlformat=getconfig("Xemailformat") htmlformat=ucase(htmlformat) if request("emailaddress") > "" then my_toaddress = request("emailaddress") else my_toaddress = getconfig("xEmail") end if my_to=getconfig("xEmailName") my_from="VP-ASP Diagnostic Test" my_Fromaddress=getconfig("xEmail") my_system=getconfig("xEmailSystem") ' imail2.innerhost.com' 'mailtype=getconfig("xEmailType") ' ASPmail, CDONTS, JMail, ASPEMAIL mailtype=mailtypes(i) ' ASPmail, CDONTS, JMail, ASPEMAIL my_subject=getconfig("xEmailsubject") body=LangTestMailInfo & mailtype & " from " & my_system & " at " & date & " " & Time() If htmlformat="HTML" then addhtml body end if 'debugwrite server.htmlencode(body) CurTest="Mailing using " & mailtype SetSess "mailerror","" acount=0 ExecuteMail mailtype,My_from,my_fromaddress,my_to,my_toaddress,my_subject,body,htmlformat,my_attachment,acount If GeTsess("mailerror")="" then if lcase(getconfig("xEmailType")) = lcase(mailtypes(i)) then AddInfoCurrent "PASS!" else AddInfo "PASS!" end if ' exit sub else if lcase(getconfig("xEmailType")) = lcase(mailtypes(i)) then AddErrorCurrent "
FAIL - " & mailtypes(i) & LangTestMailFail & "
" else AddError "
FAIL - " & mailtypes(i) & LangTestMailFail & "
" end if end if next end sub '************ Sub CheckMicrosoftError (dbc) dim counter If dbc.errors.count> 0 then ' AddError "Error count=" & dbc.errors.count For counter= 0 to dbc.errors.count-1 ' AddError "Error #" & dbc.errors(counter).number addError "Error desc. -> " & dbc.errors(counter).description next End If end sub Sub AddHtml(body) dim htmlstuff htmlstuff="" & langTestHeader & "" htmlstuff=htmlstuff & "

" body=htmlstuff & htmlformat & "
" & Body & "

" body=body & "" end sub Sub RunFileReadTests on error resume next dim whichfile(2), fsobj, recordobj, j, gotofile whichfile(0)="$readme.txt" whichfile(1)="images/shim.gif" whichfile(2)="database/shopping650.mdb" gotofile = 2 for j = 0 to gotofile CurTest="Reading " & server.mappath(whichfile(j)) set fsObj = Server.CreateObject("Scripting.FileSystemObject") set RecordObj= fsObj.OpenTextFile(server.mappath(whichfile(j)), 1, False) If Err.number=0 then AddError "PASS!" else adderror "" & err.description & "" if lcase(err.description) = "file not found" then adderror "Please ensure there is a file in your VP-ASP folder called " & whichfile(j) & " to allow this test to run correctly." end if if lcase(err.description) = "permission denied" then if instr(whichfile(j), "\") > 0 then adderror "Please check that you have read permissions set for the " & left(whichfile(j), instr(whichfile(j), "/") - 1) & " folder. For more information on permissions, please see our website." else adderror "Please check that you have read permissions set for the VP-ASP folder. For more information on permissions, please see our website." end if end if end if recordobj.close set recordobj=nothing set fsobj=nothing next end sub sub Specpageheader %> VP-ASP Shopping Cart 6.50


Welcome to the VP-ASP Diagnostics Centre. This tool will help you diagnose any problems with your database settings, email settings and file permissions.

<% end sub Sub SpecpageTrailer %>
<% end sub ' Open Access Database Sub ProcessAccessOpen_diag(connection) dim dblocation dim strconn dim database database=GetSess("db") & ".mdb" ' database name dblocation=GetSess("dblocation")' location If dblocation<>"" then database = GetSess("dblocation") & "\" & database end if if ucase(xdatabasetype)="DRIVE" Then If xAccessOle<>"Yes" then strconn = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & database else strconn = "provider=microsoft.jet.oledb.4.0;persist security info=false;data source=" & database end if 'strconn = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=D:\webs\vpasp\data\shopping2.mdb" else If xAccessole<>"Yes" then strconn = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & Server.MapPath(database) else strconn = "provider=microsoft.jet.oledb.4.0;persist security info=false;data source=" & Server.MapPath(database) end if end if if getconfig("xdebug")="Yes" then debugwrite strconn end if Set connection = Server.CreateObject("ADODB.Connection") on error resume next connection.open strConn 'SetSess "dbc", connection If connection.errors.count> 0 then SetSess "Openerror", "Open Messages
" & connection.errors(0).description & "
" & GetSess("dbc") else SetSess "Openerror","" end if End Sub 'VP-ASP 6.50 - add support for Access 20007 Sub ProcessAccess2007_diag(connection) dim dblocation dim strconn dim database database=GetSess("db") & ".accdb" ' database name dblocation=GetSess("dblocation")' location If dblocation<>"" then database = GetSess("dblocation") & "\" & database end if strconn ="Provider=Microsoft.ACE.OLEDB.12.0;persist security info=false;data source=" & Server.MapPath(database) Set connection = Server.CreateObject("ADODB.Connection") on error resume next connection.open strConn If connection.errors.count> 0 then SetSess "Openerror", "Open Messages
" & connection.errors(0).description & "
" & GetSess("dbc") else SetSess "Openerror","" end if End Sub '****************************************************************************** Sub ProcessODBC_diag (connection) on error resume next dim strconn Set connection = Server.CreateObject("ADODB.Connection") strconn=GetSess("db") ' xdatabase = ODBC connection connection.open strConn 'SetSess "dbc", connection If connection.errors.count> 0 then SetSess "Openerror", "Open Messages
" & connection.errors(0).description & "
" & GetSess("dbc") else SetSess "Openerror", "" end if end sub '****************************************************** Sub ShopOpenDatabase_diag (connection,database,databasetype) SetSess "db",database databasetype=ucase(databasetype) If databasetype="" then ProcessAccessOpen_diag connection exit sub end if if databasetype="ODBC" then database= GetSess("db") ProcessODBC_diag connection exit sub end if 'VP-ASP 6.50 - add support for Access 20007 if databasetype="ACCESS2007" then database= GetSess("db") ProcessAccess2007_diag connection exit sub end if ProcessAccessOpen_diag connection end sub %>