shopdbtest.asp

本软件可以实现的功能如下： 用户管理

<!-- #include file="shop$db.asp" -->
<!-- #include file="shopmail.asp" -->
<%
'****************************************************************************
' Diagnostic Tool for VP-ASP Shopping Cart
' Can be used to test database access and mail access
' Version 2.21  April 5 2000

'*****************************************************************************
dim sAction
Dim strbody
Dim strSubject
Dim strFrom
dim strFromemail
dim currentURL
Dim Fieldnames(20)
Dim Fieldvalues(20)
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 Msg
Dim mailtype
Dim mailer
'

sAction=request("Action")
currentURL="shopdbtest.asp"
dbtable="tbluser"
dbfield="flddatabase"
GetFieldNames
GetFieldvalues
if saction="" then
    ShopPageHeader
    DisplayForm
    AdminPageTrailer
else
    ProcessForm
    WriteDiagnosticHeader
    RunTests
    WriteDiagnosticTrailer 
end if
Sub DisplayForm
        response.write "<form name=editform action=" & currenturl & " method=POST>"
	Dim sRowColor
	sRowColor="#C4CEE5"
'	Response.Write("<blockquote>")
	Response.Write("Test your current or new configuration<br>")
	Response.Write("Changes are not automatically updated in shop$config.asp<br>")
	Response.Write("Non-Registered version do not have mail support.<br>")
	Response.Write("<font color=red>" & sErrors & "</font><br>")
	Response.Write("<table cellpadding=2 cellspacing=2 width=""80%"">")
        for i=0 to fieldcount
               fieldname = fieldnames(i)
               fieldvalue = fieldvalues(i)
               FormatRow fieldname,fieldvalue,sRowColor
  
         next
         Response.Write("</table><p>")
 	 Response.Write("<input type=submit name=action value=""DataBase Test""><br><br>")
 	 Response.Write("<input type=submit name=action value=""Mail Test"">")
         Response.Write("</form>")
'	Response.Write("</blockquote>") 
         response.write "<hr></p>"
end sub
Sub FormatRow (fieldname,fieldvalue, sRowColor)
Response.Write("<tr bgcolor=" & sRowColor &"><td width=""30%"">" & trim(fieldname) & "</td><td><input size=50 name=" & fieldname & " value=" & Chr(34) & fieldvalue & Chr(34) & "></td></tr>")
end sub
Sub ProcessForm
dim strname
dim strvalue
For Each key in Request.Form
  strname = key
  strvalue = Request.Form(key)
  Session(strname) = strvalue
  'debugwrite key & "=" &  strvalue
Next
end sub
'

Sub GetFieldnames
Fieldnames(0)="xDatabase"
Fieldnames(1)="xDblocation"
Fieldnames(2)="xEmail"
Fieldnames(3)="xEmailName"
Fieldnames(4)="xEmailSubject"
Fieldnames(5)="xEmailSystem"
Fieldnames(6)="xEmailType"
'
Fieldnames(7)="xssl"
Fieldnames(8)="xHome"
'
Fieldnames(9)="xshipping"
Fieldnames(10)="xbuttonimage"
Fieldnames(11)="xbuttontext"

'
fieldcount=11
end sub
'
Sub GetFieldvalues
Dim strvalue
strvalue=Session(fieldnames(0))
if strvalue="" then
    SetDefaultValues
else
   for i = 0 to fieldcount
      fieldvalues(i)=session(fieldnames(i))
   next
   strbody=Session("body")
end if
end sub
Sub SetDefaultValues
Fieldvalues(0)=xdatabase
Fieldvalues(1)=xdblocation
Fieldvalues(2)=xemail
Fieldvalues(3)=xemailname
Fieldvalues(4)=xemailsubject
Fieldvalues(5)=xEmailsystem
Fieldvalues(6)=xEmailType
'
FieldValues(7)=xssl
Fieldvalues(8)=xhome
Fieldvalues(9)=xshipping
Fieldvalues(10)=xbuttonimage
Fieldvalues(11)=xbuttontext
end sub
Sub RunTests
ErrorCount=0
subaction=ucase(left(sAction,4))
if subaction="MAIL" then
    RunMailtests
    exit sub
end if
if subaction="DATA" then
    RunDatabaseTests
end if
end sub
Sub RunDatabaseTests
dim dbc
dim testsql
dim testrs
dim rstemp
Serrors=""
Shopinit
Session("db")=request("xdatabase")
Session("dblocation")=request("xdblocation")
database=Session("db")
If Session("xdblocation")<>"" then
   database = Session("dblocation") & "\" & database
end if
database=database & ".mdb"
curTest="Database Open"
OpenDatabase dbc, database
on error resume next
curTest="Database Read"
testsql = "select * from " & dbtable
Set testrs = dbc.Execute(Testsql)   
fieldvalue=testrs(dbfield)
if err.number > 0 then
     addError "<b>Database cannot be read</b>"
     addError "Verify that the database is at the physical location in the open message"
     CheckMicrosoftError dbc
     Adderror Session("dbc")
else
          addError "Database can be read"
end if
testrs.close
curTest="Database Write"
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 "<b>Database cannot be written</b>"
     addError "Verify that the database is in a folder that has both read and write access"
else
    If dbc.errors.count> 0 then
      addError "<b>Database cannot be written</b>"
      addError "Verify that the database is in a folder that has both read and write access"
      CheckMicrosoftError dbc 
    else
       addError "Database can be written"
    end if
end if
dbc.close
set dbc=nothing
curTest="Summary"
if Errorcount=0 Then
   adderror "No problems reading or writing database the following is for information only"
   adderror Session("dbc") 
end if 
end sub
'
Sub addError (msg)
if curtest<>PrevTest then
      Response.write "<tr><td>" & curtest & "</td><td>"
else
      Response.write "<tr><td></td><td>"
end if
Response.write "<td>" &  msg & "</td></tr>"
errorcount=errorCount+1
PrevTest=CurTest
end sub
Sub WriteDiagnosticHeader
ShopPageHeader
Response.Write("VP-ASP Diagnostics<br>")
Response.Write("<center>")
'Response.Write("<font color=red>" & sErrors & "</font><br>")
Response.Write("<table cellpadding=2 cellspacing=2 width=""80%"">")
response.write ("<table border=2 cellspacing=0 width=""80%"" bordercolor=""#0000FF"">")

End Sub
'
Sub WriteDiagnosticTrailer
Response.Write("</table>")
AdminPageTrailer
End Sub
'
Sub RunMailTests
'****************************************************
' Run tests with user supplied mail, if it fails try CDONTS
'****************************************************
Dim description
my_toaddress = Session("xEmail")
my_to=Session("xEmailName")
my_from="VP-ASP Diagnostic Test"
my_Fromaddress=Session("xEmail")
my_system=Session("xEmailSystem")  ' imail2.innerhost.com'
mailtype=Session("xEmailType")    ' ASPmail, CDONTS, JMail
my_subject=Session("Emailsubject")
body="This is test from VP-ASP Diagnistics using " & mailtype
CurTest="Mailing using " & mailtype
ExecuteMail
if err.number=0 then
       AddError "<b>Mail OK</b>"
       exit sub
end if 
AddError "<b>" & mailtype & " is probably not installed on this system</b>"
description=err.description
AddError description
mailtype="CDONTS"
curTest="Mail using CDONTS"
ExecuteMail
if err.number=0 then
       AddError "<b>Mail using CDONTS is OK</b>"
       exit sub
end if 
AddError "<b>" & mailtype & " is probably not installed on this system</b>"
description=err.description
AddError description
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

%>