Примеры CGI на Visual Basic

Где можно найти примеры CGI на Visual Basic (на русском языке)? Есть ли такая литература?

0

Вот пример CGI на VB:
делай модуль CGI4VB.bas:
'====================================
' CGI4VB.BAS
'====================================
Option Explicit
'
' CGI routines used with VB 4.0 (32bit) using STDIN / STDOUT.
'
' Version: 1.4 (December 1996)
'

Declare Function GetStdHandle Lib 'kernel32' _
(ByVal nStdHandle As Long) As Long
Declare Function ReadFile Lib 'kernel32' _
(ByVal hFile As Long, _
lpBuffer As Any, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
lpOverlapped As Any) As Long
Declare Function WriteFile Lib 'kernel32' _
(ByVal hFile As Long, _
ByVal lpBuffer As String, _
ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, _
lpOverlapped As Any) As Long
Declare Function SetFilePointer Lib 'kernel32' _
(ByVal hFile As Long, _
ByVal lDistanceToMove As Long, _
lpDistanceToMoveHigh As Long, _
ByVal dwMoveMethod As Long) As Long
Declare Function SetEndOfFile Lib 'kernel32' _
(ByVal hFile As Long) As Long

Public Const STD_INPUT_HANDLE = -10&
Public Const STD_OUTPUT_HANDLE = -11&
Public Const FILE_BEGIN = 0&

' environment variables
'
Public CGI_Accept As String
Public CGI_AuthType As String
Public CGI_ContentLength As String
Public CGI_ContentType As String
Public CGI_GatewayInterface As String
Public CGI_PathInfo As String
Public CGI_PathTranslated As String
Public CGI_QueryString As String
Public CGI_Referer As String
Public CGI_RemoteAddr As String
Public CGI_RemoteHost As String
Public CGI_RemoteIdent As String
Public CGI_RemoteUser As String
Public CGI_RequestMethod As String
Public CGI_ScriptName As String
Public CGI_ServerSoftware As String
Public CGI_ServerName As String
Public CGI_ServerPort As String
Public CGI_ServerProtocol As String
Public CGI_UserAgent As String

Public lContentLength As Long ' CGI_ContentLength converted to Long
Public hStdIn As Long ' handle of Standard Input
Public hStdOut As Long ' handle of Standard Output
Public sErrorDesc As String ' constructed error message
Public sEmail As String ' webmaster's/your email address
Public sFormData As String ' url-encoded data sent by the server

Type pair
Name As String
Value As String
End Type

Public tPair() As pair ' array of name=value pairs

Sub Main()

On Error GoTo ErrorRoutine
InitCgi ' Load environment vars and perform other initialization
GetFormData ' Read data sent by the server
CGI_Main ' Process and return data to server

EndPgm:
End ' end program

ErrorRoutine:
sErrorDesc = Err.Description & ' Error Number = ' & Str$(Err.Number)
ErrorHandler
Resume EndPgm
End Sub

Sub ErrorHandler()
Dim rc As Long

On Error Resume Next

' use SetFilePointer API to reset stdOut to BOF
' and SetEndOfFile to reset EOF

rc = SetFilePointer(hStdOut, 0&, 0&, FILE_BEGIN)

SendHeader 'Internal Error'
Send '<H1>Error in ' & CGI_ScriptName & '</H1>'

Send 'The following internal error has occurred:'
Send '<PRE>' & sErrorDesc & '</PRE>'
Send '<I>Please</I> note what you were doing when this problem occurred, '
Send 'so we can identify and correct it. Write down the Web page you were '
Send 'using, any data you may have entered into a form or search box, '
Send 'and anything else that may help us duplicate the proble delim1 = InStr(pointer, sData, '=')
If delim1 = 0 Then Exit Do
pointer = delim1 + 1
lPairs = lPairs + 1
Loop

If lPairs = 0 Then Exit Sub 'nothing to add

' redim tPair() based on the number of pairs found in sData
ReDim Preserve tPair(lastPair + lPairs) As pair

' assign values to tPair().name and tPair().value
pointer = 1
For n = (lastPair + 1) To UBound(tPair)
delim1 = InStr(pointer, sData, '=') ' find next equal sign
If delim1 = 0 Then Exit For ' parse complete

tPair(n).Name = UrlDecode(Mid$(sData, pointer, delim1 - pointer))

delim2 = InStr(delim1, sData, '&')

' if no trailing ampersand, we are at the end of data
If delim2 = 0 Then delim2 = Len(sData) + 1

' value is between the '=' and the '&'
tPair(n).Value = UrlDecode(Mid$(sData, delim1 + 1, delim2 - delim1 - 1))
pointer = delim2 + 1
Next n
End Sub

Public Function UrlDecode(ByVal sEncoded As String) As String
'======================================= =================
' Accept url-encoded string
' Return decoded string
'======================================= =================

Dim pointer As Long ' sEncoded position pointer
Dim pos As Long ' position of InStr target

If sEncoded = '' Then Exit Function

' convert '+' to space
pointer = 1
Do
pos = InStr(pointer, sEncoded, '+')
If pos = 0 Then Exit Do
Mid$(sEncoded, pos, 1) = ' '
pointer = pos + 1
Loop

' convert '%xx' to character
pointer = 1

On Error GoTo errorUrlDecode

Do
pos = InStr(pointer, sEncoded, '%')
If pos = 0 Then Exit Do

Mid$(sEncoded, pos, 1) = Chr$('&H' & (Mid$(sEncoded, pos + 1, 2)))
sEncoded = Left$(sEncoded, pos) _
& Mid$(sEncoded, pos + 3)
pointer = pos + 1
Loop
On Error GoTo 0 'reset error handling
UrlDecode = sEncoded
Exit Function

errorUrlDecode:
'--------------------------------------------------------------------
' If this function was mistakenly called with the following:
' UrlDecode('100% natural')
' a type mismatch error would be raised when trying to convert
' the 2 characters after '%' from hex to character.
' Instead, a more descriptive error message will be generated.
'--------------------------------------------------------------------
If Err.Number = 13 Then 'Type Mismatch error
Err.Clear
Err.Raise 65001, , 'Invalid data passed to UrlDecode() function.'
Else
Err.Raise Err.Number
End If
Resume Next
End Function

Function GetCgiValue(cgiName As String) As String
'======================================= =============================
' Accept the name of a pair
' Return the value matching the name
'
' tPair(0) is always empty.
' An empty string will be returned
' if cgiName is not defined in the form (programmer error)
' or, a select type form item was used, but no item was selected.
'
' Multiple values, separated by a semi-colon, will be returned
' if the form item uses the 'multiple' option
' and, more than one selection was chosen.
' The calling procedure must parse this string as needed.
'======================================= =============================
Dim n As Integer

For n = 1 To UBound(tPair)
If UCase$(cgiName) = UCase$(tPair(n).Name) Then
If GetCgiValue = '' Then
GetCgiValue = tPair(n).Value
Else ' allow for multiple selections
GetCgiValue = GetCgiValue & ';' & tPair(n).Value
End If
End If
Next n
End Function

Sub SendHeader(sTitle As String)
Send 'Status: 200 OK'
Send 'Content-type: text/html' & vbCrLf
Send '<HTML><HEAD><TITLE>' & sTitle & '&lt

Спасибо. Благодарю.

0

Вот еще 3 примера
http://www.tbrown.dircon.co.uk/vb/cgi.htm

0