orderdb.bas

加入一个用VB编写CGI的VB源程序。（你需要在Win98上首先安装20Personal WebServer

Attribute VB_Name = "Module1"
Option Explicit
'----------------------------------------------------------
'OrderDB.bas - process an order received from an HTML form.
'              Use an MDB database.
'----------------------------------------------------------
Dim db As Database
Dim rs As Recordset

Public sName    As String        'subscriber name
Public sAddress As String        'subscriber name
Public sAction  As String        'action to be performed by script




Sub Cgi_main()

'retrieve order information from the form

sName = GetCgiValue("name")
sAddress = GetCgiValue("address")
sAction = GetCgiValue("action")

SendHeader "CGI4VB Mailing List Database"

'Validate form fields
'Required fields

If Trim$(sName) = "" Or Trim$(sAddress) = "" Then
   Send "We cannot process your order.<br>" _
      & "We need both your name and your e-mail address.<br>" _
      & "Please go back and re-enter the information."
   Exit Sub
End If

'Perform minimal validation on e-mail address.
'check for "@"

If InStr(sAddress, "@") = 0 Then
   Send "The e-mail address that you entered does not appear " _
      & "to be valid.<br>The symbol ""@"" is required. "
   Exit Sub
End If

Set db = OpenDatabase("d:\prog\vb4\orderDB\orderDB.mdb")
Set rs = db.OpenRecordset("MailList")

Select Case sAction
Case "subscribe"
      Subscribe
Case "unsubscribe"
      Unsubscribe
Case "view"
      View
End Select
SendFooter
rs.Close
db.Close
End Sub

Sub Subscribe()

'try to find the requested record
rs.Index = "idxAddress"
rs.Seek "=", sAddress

If rs.NoMatch Then                        'Record not found
   rs.AddNew                              'prepare a new record
   rs!Name = sName
   rs!Address = sAddress
   Send "Thank you for your order. Your first issue " _
      & "should arrive within one week."
   rs.Update                              'add the record
Else
   Send "Your address is already on file."
End If
End Sub

Sub Unsubscribe()
'try to find the requested record
rs.Index = "idxAddress"
rs.Seek "=", sAddress

If rs.NoMatch Then                        'Record not found
   Send "You are not currently an active subscriber."
Else
   rs.Delete                            'delete the record
   Send "Your address has been removed from the mailing list."
End If
End Sub

Sub View()
If rs.EOF And rs.BOF Then
   Send "The mailing List Database is Empty"
Else
   Do Until rs.EOF
      Send rs!Name & " " & rs!Address & "<br>"
      rs.MoveNext
   Loop
End If
End Sub