Visual Basicを使ったCGIによるWEBデータベースアクセス
（サンプルリスト）

リスト1：郵便番号入力フォーム

リスト2：郵便番号検索プログラムコード

リスト3：プログラムにより生成された結果画面

リスト4：Web Extenderサンプル画面のHTML

リスト5：Actionメソッド

リスト6：CreateResponse関数

リスト7：SaveDbプロシージャ（送信されたデータをDBに格納）

リスト8：ActiveHtml関数（テーブルの内容を参照し，HTMLに変換）


▼ CGI4VB日本語版サブセット　ソースコード

▼ Web Extender プログラム開発用　テンプレートコード


本文ヘ戻る

リスト1：郵便番号入力フォーム 

<html>
<head><title>Visual Basic Magazine</title>
</head>
<body>
<center>
<h1>VBによるCGIデータアクセスプログラム</h1>
<FORM ACTION="vbcgi.exe" METHOD="post">   
  郵便番号<br>
    <INPUT name="field1" maxlength="5" size="5">
  <br><br>
    <INPUT type="submit" value =" 検索 ">
  <br><br>
  <hr>
  入力テスト1<br>
    On<Input Type="radio" name="field2" Value="On">
    Off<Input Type="radio" name="field2" Value="Off" Checked>
  <br><br>
  入力テスト2<br>
    <Select name="field3" Size=3 Multiple>
    <Option Value="Visual Basic"  selected>Visual Basic
    <Option Value="Delphi" >Delphi
    <Option Value="Visual C++" >Visual C++
    </Select>
  <br><br>
</form>
</center>
</body>
</html>


リスト2：郵便番号検索プログラムコード 

Sub Cgi_Main()
  'データベースオブジェクトの作成
  Dim ws As Workspace
  Dim qdef_inall As QueryDef
  Dim db_take As Database
  Dim rs As Recordset
  Set ws = DBEngine.Workspaces(0)
  Dim dbname As String
  dbname = App.Path + "\yubin.mdb"
  Set db_take = ws.OpenDatabase(dbname)
  Dim SQLstat As String
  'HTMLのヘッダー部を作成
  Send "Content-type: text/html" & vbCrLf
  Send "<HTML><HEAD>"
  Send "<TITLE>CGI4VB Output</TITLE>"
  Send "</HEAD>"
  Send "<hr>"
  Send "<H2>検索結果</H2>"
  'SQL文を作成し，検索を実行
  SQLstat = "select * from yubin where zipcode = '" _
          + GetCgiValue("field1") + "'"
  Set rs = db_take.OpenRecordset(SQLstat, dbOpenSnapshot)
  '検索結果をヒット数分だけHTMLファイルに出力
  Do Until rs.EOF
    Send rs("address") + "<BR>"
    rs.MoveNext
  Loop
  Send "<hr>"
  'SQL ステートメントを表示
  Send "<H2>SQL statement</H2><BR>"
  Send SQLstat
  Send "<hr>"
  '送信フォームの入力値を表示
  Send "<H2>Form Values</H2>"
  Send "郵便番号　　" & GetCgiValue("field1") & " <br>"
  Send "入力テスト1 " & GetCgiValue("field2") & " <br>"
  Send "入力テスト2 " & GetCgiValue("field3") & " <br>"
  Send "<hr>"
End Sub


リスト3：プログラムにより生成された結果画面 

<HTML><HEAD>
<TITLE>CGI4VB Output</TITLE>
</HEAD>
<hr>
<H2>検索結果</H2>
神奈川県横浜市港北区下田町<BR>
神奈川県横浜市港北区新吉田町<BR>
神奈川県横浜市港北区高田町<BR>
神奈川県横浜市港北区綱島上町<BR>
神奈川県横浜市港北区綱島台<BR>
神奈川県横浜市港北区綱島東<BR>
神奈川県横浜市港北区綱島西<BR>
神奈川県横浜市港北区新羽町<BR>
神奈川県横浜市港北区日吉<BR>
神奈川県横浜市港北区日吉本町<BR>
神奈川県横浜市港北区箕輪町<BR>
<hr>
<H2>SQL statement</H2><BR>
select * from yubin where zipcode = '223'
<hr>
<H2>Form Values</H2>
郵便番号　　223 <br>


リスト4：Web Extenderサンプル画面のHTML 

<HR>
<BR>
<FONT SIZE=4>このプログラムはテキストボックスに入力
した値をMDB形式のデータベースに格納します。</FONT>
<BR>
<BR>
<BR>
<FONT SIZE=4>
<FORM ACTION = "/scripts/gwiisole.dll/
DbAccess.MainClass.Action" method="POST"></FONT><BR>
<FONT SIZE=4>
<INPUT TYPE = "submit" value="POST">
このPOSTボタンを押すと入力ボックスの値がサーバーへ
</FONT><BR>
<FONT SIZE=4>送信されます。</FONT><BR>
<BR>
  <TABLE><BR><TR>
  <TD ALIGN="RIGHT" VALIGN="TOP">
  <FONT SIZE=4>名前</TD><TD><INPUT NAME ="Name"></FONT>
  </TD><TR>
  <BR>
　  <TD ALIGN="RIGHT" VALIGN="TOP">
  <FONT SIZE=4>電話</TD><TD><INPUT NAME="Phone"></FONT>
  </TD><TR>
  <BR>
  <TD ALIGN="RIGHT" VALIGN="TOP">
  <FONT SIZE=4>備考</TD><TD>
  <INPUT NAME="Comments" type="textarea" size="20,5" maxlength="250">
  </FONT></TD><TR>
  </TABLE>
<FONT SIZE=4>
</FORM></FONT><BR>
<A HREF="/scripts/gwiisole.dll/
DbAccess.MainClass.Action">
ここ</A></FONT>をクリックすると<BR>
データベースにアクセスし動的にHTML文書を作成し返します。<P>
<BR>
<A HREF="/scripts/gwiisole.dll/
DbAccess.MainClass.Action?init">
ここ</A>をクリックすると<BR>
データベースを初期化します。<P>


リスト5：Actionメソッド 

Sub Action(request As String, Response As String)
Dim Resp As String
  On Error GoTo Erl
  Resp = CreateResponse(request)
  Response = StrConv(Resp, vbFromUnicode)
  Exit Sub
Erl:
  Resp = "0" & ContentTypeMsg _
       & "<H3> Visual Bsaic Error No ="  _
       & Str$(Err) & Str$(ErrNo) _
       & "<P>" & Error$ & "</H3>"
  Response = StrConv(Resp, vbFromUnicode)
End Sub


リスト6：CreateResponse関数 

Private Function CreateResponse(request As String) As String
Dim Response As String
  Response = CreateHeader()
  If REQUEST_METHOD = "POST" Then
    'postメソッドの場合データをデータベースに
    '格納し正常に格納したことを返します．
    SaveDb request
    Response = Response & _
             "<BODY><H1>データをデータベースに格納しました．" _
             & "</H1>" & "<H4><A HREF=""/default.htm"">戻る</A>"
  Else
    If QUERY_STRING = "init" Then
      Response = Response _
               & "<BODY><H1>データベースを初期化しました．" _
               & "</H1>" &  "<H4><A HREF=""/default.htm"">戻る</A>"
      Kill "sample.mdb"
      SaveDb ""
    Else
      'データベースを読み出して動的にHTMLを作成します．
      Response = Response & _
               "<BODY><H1>データベースから動的にHTMLを作成しました．" _
               & "</H1>" & "<H4>"
      Response = Response & ActiveHtml
    End If
  End If
  CreateResponse = Response & "</H4></BODY>"
       
End Function


リスト7：SaveDbプロシージャ（送信されたデータをDBに格納） 

Sub SaveDb(request As String)
Dim MyWs As Workspace
Dim MyDb As Database
Dim MyTb As TableDef
Dim MyRec As Recordset
Dim Fid(2) As Field
Dim MyIdx As Index
Dim i As Integer
Dim DbFieldName(2) As String
Dim DbFieldValue(2) As String
Dim Fined As Integer
Dim PrevFined As Integer
  Set MyWs = DBEngine.Workspaces(0)
  If Dir$("sample.mdb") = "" Then
    'データベースを作成します．
    Set MyDb = MyWs.Createdatabase _
        ("sample.mdb", dbLangJapanese)
    Set MyTb = MyDb.CreateTableDef _
        ("Discription")
    
    'テーブルの作成
    Set Fid(0) = MyTb.CreateField _
        ("Name", dbText, 25)
    Set Fid(1) = MyTb.CreateField _
        ("Phone", dbText, 12)
    Set Fid(2) = MyTb.CreateField _
        ("Comments", dbText, 50)
    For i = 0 To 2
      MyTb.Fields.Append Fid(i)
    Next i
    MyDb.TableDefs.Append MyTb
    
    'インデックスの作成
    Set MyIdx = MyTb.CreateIndex("Primary")
    MyIdx.Primary = True
    MyIdx.Unique = False
    Set Fid(0) = MyIdx.CreateField("Name")
    MyIdx.Fields.Append Fid(0)
    MyTb.Indexes.Append MyIdx
    'MyDb.Close
  End If
  'データを分割します．
  If request <> "" Then
    PrevFined = 1
    For i = 0 To 2
      Fined = InStr(PrevFined, request, "=")
      DbFieldName(i) = _
                 Mid$(request, PrevFined, Fined - PrevFined)
      PrevFined = Fined + 1
      If Fined < Len(request) Then
        Fined = InStr(PrevFined, request, "&")
        If Fined = 0 Then Fined = Len(request)
          DbFieldValue(i) = _
                      Mid$(request, PrevFined, Fined - PrevFined)
      Else
        DbFieldValue(i) = ""
      End If
      PrevFined = Fined + 1
    Next i
    
    'データを格納します｡
    Set MyDb = _
        MyWs.OpenDatabase("sample.mdb")
    Set MyRec = _
        MyDb.OpenRecordset("Discription", dbOpenTable)
    MyRec.AddNew
    For i = 0 To 2
      If DbFieldValue(i) = "" Then DbFieldValue(i) = " "
      MyRec.Fields(DbFieldName(i)) = DbFieldValue(i)
    Next i
    MyRec.Update
    MyRec.Close
    MyDb.Close
  End If
  MyWs.Close
End Sub


リスト8：ActiveHtml関数（テーブルの内容を参照し，HTMLに変換） 

Function ActiveHtml() As String
Dim MyWs As Workspace
Dim MyDb As Database
Dim MyRec As Recordset
Dim Resp As String
  'データベースを開きます
  If Dir$("sample.mdb") <> "" Then
    Set MyWs = _
        DBEngine.Workspaces(0)
    Set MyDb = _
        MyWs.OpenDatabase("sample.mdb")
    Set MyRec = _
        MyDb.OpenRecordset("Discription", dbOpenTable)
    'レコードの先頭をカレントにします．
    Resp = "<TABLE border = 1>" _
           & "<TR><TD>名前</TD><TD>" _
           & "電話</TD><TD>備考</TD></TR>"
    If Not MyRec.EOF Then
      MyRec.MoveFirst
      Resp = "<TABLE border = 1>" _
           & "<TR><TD>名前</TD><TD>" _
           & "電話</TD><TD>備考</TD></TR>"
      Do
        'データを読み出します．
        Resp = Resp _
             & "<TR><TD>" & MyRec.Fields(0) & "</TD>"
        Resp = Resp _
             & "<TD>" & MyRec.Fields(1) & "</TD>"
        Resp = Resp _
             & "<TD>" & MyRec.Fields(2) & "</TD></TR>"
        MyRec.MoveNext
      Loop Until MyRec.EOF
    End If
    MyRec.Close
    MyDb.Close
    MyWs.Close
    Resp = Resp & " </TABLE>"
  Else
    Resp = "データベースが作成されていません．<P>"
    
  End If
    
  ActiveHtml = Resp
End Function



▼ CGI4VB日本語版サブセット　ソースコード 

Option Explicit
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 CGI_ContentLength     As String
Public lContentLength As Long
Public lPairs         As Long
Public hStdIn         As Long
Public hStdOut        As Long

Type pair
  Name As String
  Value As String
End Type
Public tPair() As pair

'------------------------------------------

Function GetCgiValue(cgiName As String) As String
  Dim n As Integer
  GetCgiValue = ""
  For n = 0 To (lPairs - 1)
    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 Main()
  Dim x As Integer
  hStdIn = GetStdHandle(STD_INPUT_HANDLE)
  hStdOut = GetStdHandle(STD_OUTPUT_HANDLE)
  CGI_ContentLength = Environ("CONTENT_LENGTH")
  lContentLength = Val(CGI_ContentLength)
  
  Dim sFormData  As String    ' url-encoded data returned from the form
  Dim sBuff      As String    ' buffer to receive POST method data
  Dim sValue     As String    ' temp string to hold a form item value
  Dim lBytesRead As Long      ' actual bytes read by POST method
  Dim rc         As Long      ' return code
  Dim pointer    As Long      ' sFormData position pointer
  Dim xp         As Long      ' sValue    position pointer
  Dim n          As Long      ' name/value pair counter
  Dim pos        As Long      ' position of InStr target
  Dim delim1     As Long      ' position of "="
  Dim delim2     As Long      ' position of "&"
  sBuff = String(lContentLength, Chr$(0))
  lBytesRead = lContentLength
  rc = ReadFile(hStdIn, ByVal sBuff, lContentLength, lBytesRead, ByVal 0&)
  sFormData = Left(sBuff, lBytesRead)
  ' Store name/value pairs in array tPair(), and decode the values
  ' redim tPair() based on the number of pairs found in sFormData
  pointer = 1
  lPairs = 0
  Do
    delim1 = InStr(pointer, sFormData, "=")
    If delim1 = 0 Then Exit Do
    pointer = delim1 + 1
    lPairs = lPairs + 1
  Loop
  ReDim tPair(lPairs) As pair
' assign values to tPair().name and tPair().value
  pointer = 1
  For n = 0 To (lPairs - 1)
    delim1 = InStr(pointer, sFormData, "=") ' find next equal sign
    If delim1 = 0 Then Exit For             ' parse complete
    tPair(n).Name = Mid$(sFormData, pointer, delim1 - pointer)
    delim2 = InStr(delim1, sFormData, "&")
    ' if no trailing ampersand, we are at the end of data
    If delim2 = 0 Then delim2 = Len(sFormData) + 1
    ' value is between the "=" and the "&"
    sValue = Mid$(sFormData, delim1 + 1, delim2 - delim1 - 1)
    ' decode: convert "+" to space
    xp = 1
   Do
     pos = InStr(xp, sValue, "+")
     If pos = 0 Then Exit Do
     Mid$(sValue, pos, 1) = " "
     xp = pos + 1
   Loop
   ' decode: convert "%xx" to ASCII character
   xp = 1
   Do
     pos = InStr(xp, sValue, "%")
     If pos = 0 Then Exit Do
     Mid$(sValue, pos, 1) = Chr$(Val("&H" & (Mid$(sValue, pos + 1, 2))))
     sValue = Left$(sValue, pos) & Mid$(sValue, pos + 3)
     xp = pos + 1
   Loop
   tPair(n).Value = sValue
   pointer = delim2 + 1
 Next n
 
 Cgi_Main         ' Process and return data to browser
End Sub

'------------------------------------------

Sub Send(s As String)
  Dim rc As Long
  Dim dbcscount As Integer
  Dim i As Integer
  Dim maxloop As Integer
  
  maxloop = Len(s)
  dbcscount = 0
  i = 0
  Do While i < maxloop
  i = i + 1
   If Asc(Mid(s, i, 1)) <> AscB(Mid(s, i, 1)) Then
      dbcscount = dbcscount + 1
   End If
  Loop
  
  s = s & vbCrLf
  Dim lens As Integer
  lens = Len(s) + dbcscount
  WriteFile hStdOut, s, lens, rc, ByVal 0&
End Sub


▼ Web Extender プログラム開発用　テンプレートコード 

Option Explicit
Public AUTH_TYPE As String
Public CONTENT_LENGTH As String
Public CONTENT_TYPE As String
Public GATEWAY_INTERFACE As String
Public PATH_INFO As String
Public PATH_TRANSLATED As String
Public QUERY_STRING As String
Public REMOTE_ADDR As String
Public REMOTE_HOST As String
Public REMOTE_USER As String
Public REQUEST_METHOD As String
Public SCRIPT_NAME As String
Public SERVER_NAME As String
Public SERVER_PORT As String
Public SERVER_PROTOCOL As String
Public SERVER_SOFTWARE As String
Public AUTH_PASS As String
Public ALL_HTTP As String
Public HTTP_ACCEPT As String
Public HTTP_USER_AGENT As String
Public AUTH_USER As String
Public HTTP_COOKIE As String
Dim ErrNo
'ヘッダー定義
Const ContentTypeMsg = "Content-Type: text/html" & vbCrLf & vbCrLf

'//基本認証に関する定義
Const USERAUTHNEED = False
Const AUTHMSG = "WWW-Authenticate: Basic realm="" PWTEST Example"""
Const RefuseMsg = "<HTML><body> <H1>認証できませんでした。<P>" _
                  & "正しいアカウントを取得してください</H1></body></HTML> "


'//COOKIEに関する定義
Const NEEDCOOKIE = False

'//ダイレクト URL レスポンスに関する定義
Const DirectResponce = False
Const ArrowURL = ""

'------------------------------------------

Private Function CheckAuth() As Integer
'//ユーザー認証のコードを記述します。
CheckAuth = True
End Function

'------------------------------------------

Private Function CreateCookie() As String
'//COOKIEを使用する場合ここに記述します。

If NEEDCOOKIE Then
    CreateCookie = "Set-Cookie: NAME=""aBcDe""" & vbCrLf
Else
    CreateCookie = ""
End If
End Function

'------------------------------------------

Private Function CreateHeader() As String
'//ヘッダーを作成します。

Dim ResponseNo As String
    
    If Not USERAUTHNEED Then
        ResponseNo = "0"
    ElseIf Trim$(AUTH_USER) = "" Then
        ResponseNo = "1"
    ElseIf CheckAuth Then
        ResponseNo = "0"
    Else
        ResponseNo = "1"
    End If
    
    If DirectResponce And ResponseNo = "0" Then ResponseNo = "2"
    
    If ResponseNo = "0" Then
        CreateHeader = ResponseNo & CreateCookie() & ContentTypeMsg
    ElseIf ResponseNo = "1" Then
        CreateHeader = ResponseNo & AUTHMSG & ContentTypeMsg & RefuseMsg
    Else
        CreateHeader = ResponseNo & ArrowURL
    End If
End Function

本文ヘ戻る

Visual Basic Magazine ライブラリ | Visual Basicコースホームページ
int21 ホームページ | PCDN ホームページ

PCDN LOGO