| Function | Description |
|
GetSmallField (key As String) As String |
Takes the key of a key-value pair for an input field as a parameter and returns its value as a string. For example, if your online form has a text box called "name", then GetSmallField("name") returns what the user typed in that text box. If the field does not exist, you get an error. |
|
FieldPresent (key As String) As Integer |
Tests the existence of a field name explicitly, and returns either True or False. |
|
Send (s As String) |
Sends the output string, which will be passed to the client by the Web server. Depending on the Web server, sometimes you need to include the HTTP header in your output. For example, to generate a one-word Web page in WebSite 1.1, you need to use the following code: |
' custom.bas
Option Explicit
Const DIRECTORY = "D:\Web temp\cgi2asp\directory.mdb"
Const HOST = "http://10.1.1.2"
Const SEARCH = "search.exe"
Sub Inter_Main()
MsgBox "This is a CGI program."
' Exit Sub will end the program
End Sub
Sub SendFooter()
Send ("</BODY></HTML>")
End Sub
Sub SendHeader(Title As String)
Send ("HTTP/1.0 200 OK")
Send ("Server: " & CGI_ServerSoftware)
Send ("MIME-Version: 1.0")
Send ("Content-type: text/html")
Send ("")
Send ("<HTML><HEAD><TITLE>" & Title & "</TITLE></HEAD>")
Send ("<BODY BGCOLOR=""#FFFFFF"">")
End Sub
Sub SendShortForm()
SendHeader ("Employee Directory")
Send ("<H1><P ALIGN=""center"">Online Employee Directory</P></H1>")
Send ("")
Send ("<FORM METHOD=""POST"" ACTION=""" & SEARCH & """>")
Send ("")
Send ("Please type in the name of the person you want to look up: <BR>")
Send ("<P><INPUT NAME=""name"" SIZE=20>")
Send ("<INPUT TYPE=""submit"" VALUE=""Search"">")
Send ("</P>")
Send ("</FORM>")
SendFooter
End Sub
Sub CGI_Main()
If CGI_RequestMethod = "GET" Then
SendShortForm
Exit Sub
Else
SendResponse
Exit Sub
End If
End Sub
Sub SendResponse()
Dim SearchDb As Database
Dim SearchSet As Recordset
Dim SearchString As String
SearchString = GetSmallField("name")
Set SearchDb = DBEngine.Workspaces(0).OpenDatabase(DIRECTORY, False, True)
Set SearchSet = SearchDb.OpenRecordset("SELECT [Name], [Extension] FROM" &
"[Employee] WHERE Name LIKE '*" & SearchString & "*'",
dbOpenSnapshot)
SendHeader ("Search Result")
Send ("<H2>Search Result</H2><BR>")
Send ("<TABLE BORDER>")
Send ("<TR>")
Send ("<TH>Name</TH>")
Send ("<TH>Extension</TH>")
Send ("</TR>")
Do Until SearchSet.EOF
Send ("<TR><TD ALIGN=""CENTER"">" & SearchSet![name] & "</TD>")
Send ("<TD ALIGN=""CENTER"">" & SearchSet![Extension] & "</TD>")
Send ("</TR>")
SearchSet.MoveNext
Loop
Send ("</TABLE>")
SendFooter
SearchSet.Close
SearchDb.Close
End Sub
cgi2asp.bas
' cgi2asp.bas
Option Explicit
Option Private Module
Dim objInput As Request
Dim strOutput As String
Dim ErrorString As String
' ------------------
' Custom Error Codes
' ------------------
Public Const ERR_NO_FIELD = 32757
' ----------------------
' Standard CGI variables
' ----------------------
Public CGI_ServerSoftware As String
Public CGI_ServerName As String
Public CGI_ServerPort As Integer
Public CGI_RequestProtocol As String
Public CGI_RequestMethod As String
Public CGI_LogicalPath As String
Public CGI_PhysicalPath As String
Public CGI_QueryString As String
Public CGI_Referer As String
Public CGI_UserAgent As String
Public CGI_RemoteHost As String
Public CGI_RemoteAddr As String
Public CGI_AuthUser As String
Public CGI_AuthType As String
Public CGI_ContentType As String
Public CGI_ContentLength As Long
Sub ErrorHandler(code As Integer)
strOutput = "" ' Rewind output
Send ("<HTML><HEAD>")
Send ("<TITLE>Error in " + CGI_LogicalPath + "</TITLE>")
Send ("</HEAD><BODY>")
Send ("<H1>Error in " + CGI_LogicalPath + "</H1>")
Send ("An internal Visual Basic error has occurred in " + CGI_LogicalPath + ".")
Send ("<PRE>" + ErrorString + "</PRE>")
Send ("</BODY></HTML>")
End Sub
Function FieldPresent(key As String) As Integer
Dim i As Integer
Dim Item As Variant
FieldPresent = False ' Assume failure
For Each Item In objInput.QueryString
Select Case objInput.QueryString(Item).Count
Case 0 ' Not a collection
If Item = key Then
FieldPresent = True
Exit Function
End If
Case 1 ' Single selection
If Item = key Then
FieldPresent = True
Exit Function
End If
Case Else ' Multiple selections
If Item = key Then ' Expecting first selection
FieldPresent = True
Exit Function
Else ' Expecting other selections in the form of multiple_i
For i = 2 To objInput.QueryString(Item).Count
If Item & "_" & CStr(i - 1) = key Then
FieldPresent = True
Exit Function
End If
Next
End If
End Select
Next
For Each Item In objInput.Form
Select Case objInput.Form(Item).Count
Case 0 ' Not a collection
If Item = key Then
FieldPresent = True
Exit Function
End If
Case 1 ' Single selection
If Item = key Then
FieldPresent = True
Exit Function
End If
Case Else ' Multiple selections
If Item = key Then ' Expecting first selection
FieldPresent = True
Exit Function
Else ' Expecting other selections in the form of multiple_i
For i = 2 To objInput.Form(Item).Count
If Item & "_" & CStr(i - 1) = key Then
FieldPresent = True
Exit Function
End If
Next
End If
End Select
Next
'
' Field does not exist, so exit with FieldPresent still False
'
End Function
Function GetSmallField(key As String) As String
Dim i As Integer
Dim Item As Variant
For Each Item In objInput.QueryString
Select Case objInput.QueryString(Item).Count
Case 0 ' Not a collection
If Item = key Then
GetSmallField = objInput.QueryString(Item)
Exit Function
End If
Case 1 ' Single selection
If Item = key Then
GetSmallField = objInput.QueryString(Item)(1)
Exit Function
End If
Case Else ' Multiple selections
If Item = key Then ' Expecting first selection
GetSmallField = objInput.QueryString(Item)(1)
Exit Function
Else ' Expecting other selections in the form of multiple_i
For i = 2 To objInput.QueryString(Item).Count
If Item & "_" & CStr(i - 1) = key Then
GetSmallField = objInput.QueryString(Item)(i)
Exit Function
End If
Next
End If
End Select
Next
For Each Item In objInput.Form
Select Case objInput.Form(Item).Count
Case 0 ' Not a collection
If Item = key Then
GetSmallField = objInput.Form(Item)
Exit Function
End If
Case 1 ' Single selection
If Item = key Then
GetSmallField = objInput.Form(Item)(1)
Exit Function
End If
Case Else ' Multiple selections
If Item = key Then ' Expecting first selection
GetSmallField = objInput.Form(Item)(1)
Exit Function
Else ' Expecting other selections in the form of multiple_i
For i = 2 To objInput.Form(Item).Count
If Item & "_" & CStr(i - 1) = key Then
GetSmallField = objInput.Form(Item)(i)
Exit Function
End If
Next
End If
End Select
Next
'
' Field does not exist
'
Error ERR_NO_FIELD
End Function
Sub InitializeCGI()
CGI_ServerSoftware = objInput.ServerVariables("SERVER_SOFTWARE")
CGI_ServerName = objInput.ServerVariables("SERVER_NAME")
CGI_ServerPort = objInput.ServerVariables("SERVER_PORT")
CGI_RequestProtocol = objInput.ServerVariables("SERVER_PROTOCOL")
CGI_RequestMethod = objInput.ServerVariables("REQUEST_METHOD")
CGI_LogicalPath = objInput.ServerVariables("PATH_INFO")
CGI_PhysicalPath = objInput.ServerVariables("PATH_TRANSLATED")
CGI_QueryString = objInput.ServerVariables("QUERY_STRING")
CGI_RemoteHost = objInput.ServerVariables("REMOTE_HOST")
CGI_RemoteAddr = objInput.ServerVariables("REMOTE_ADDR")
CGI_Referer = objInput.ServerVariables("HTTP_REFERER")
CGI_UserAgent = objInput.ServerVariables("HTTP_USER_AGENT")
CGI_AuthUser = objInput.ServerVariables("REMOTE_USER")
CGI_AuthType = objInput.ServerVariables("AUTH_TYPE")
CGI_ContentType = objInput.ServerVariables("CONTENT_TYPE")
CGI_ContentLength = objInput.ServerVariables("CONTENT_LENGTH")
End Sub
Function Main(reqInput As Request) As String
On Error GoTo ErrorHandler
Set objInput = reqInput
InitializeCGI ' Create the CGI environment
CGI_Main
Main = strOutput
'------------
ErrorHandler:
Select Case Err ' Decode our "user defined" errors
Case ERR_NO_FIELD:
ErrorString = "Unknown form field"
Case Else:
ErrorString = Error ' Must be VB error
End Select
ErrorString = ErrorString & " (error #" & Err & ")"
On Error GoTo 0 ' Prevent recursion
ErrorHandler (Err) ' Generate HTTP error result
'------------
End Function
Sub Send(s As String)
strOutput = strOutput & s
End Sub
interface.cls
' interface.cls
Public Function GetOutput(reqInput As Request) As String
GetOutput = Main(reqInput)
End Function
Option Explicit
Const DIRECTORY = "D:\Web temp\cgi2asp\directory.mdb"
Const HOST = "http://10.1.1.1"
Const SEARCH = "search.asp"
Sub Inter_Main()
MsgBox "This is a CGI program."
' Exit Sub will end the program
End Sub
Sub SendFooter()
Send ("</BODY></HTML>")
End Sub
Sub SendHeader(Title As String)
' Send ("HTTP/1.0 200 OK")
' Send ("Server: " & CGI_ServerSoftware)
' Send ("MIME-Version: 1.0")
' Send ("Contet-type: text/html")
' Send ("")
Send ("<HTML><HEAD><TITLE>" & Title & "</TITLE></HEAD>")
Send ("<BODY BGCOLOR=""#FFFFFF"">")
End Sub
Sub SendShortForm()
SendHeader ("Employee Directory")
Send ("<H1><P ALIGN=""center"">Online Employee Directory</P></H1>")
Send ("")
Send ("<FORM METHOD=""POST"" ACTION=""" & SEARCH & """>")
Send ("")
Send ("Please type in the name of the person you want to look up: <BR>")
Send ("<P><INPUT NAME=""name"" SIZE=20>")
Send ("<INPUT TYPE=""submit"" VALUE=""Search"">")
Send ("</P>")
Send ("</FORM>")
SendFooter
End Sub
Sub CGI_Main()
If CGI_RequestMethod = "GET" Then
SendShortForm
Exit Sub
Else
SendResponse
Exit Sub
End If
End Sub
Sub SendResponse()
Dim SearchDb As Database
Dim SearchSet As Recordset
Dim SearchString As String
SearchString = GetSmallField("name")
Set SearchDb = DBEngine.Workspaces(0).OpenDatabase(DIRECTORY, False, True)
Set SearchSet = SearchDb.OpenRecordset("SELECT [Name], [Extension] FROM" &
"Employee] WHERE Name LIKE '*" & SearchString & "*'",
dbOpenSnapshot)
SendHeader ("Search Result")
Send ("<H2>Search Result</H2><BR>")
Send ("<TABLE BORDER>")
Send ("<TR>")
Send ("<TH>Name</TH>")
Send ("<TH>Extension</TH>")
Send ("</TR>")
Do Until SearchSet.EOF
Send ("<TR><TD ALIGN=""CENTER"">" & SearchSet![Name] & "</TD>")
Send ("<TD ALIGN=""CENTER"">" & SearchSet![Extension] & "</TD>")
Send ("</TR>")
SearchSet.MoveNext
Loop
Send ("</TABLE>")
SendFooter
SearchSet.Close
SearchDb.Close
End Sub