テクニカルノート10a:

ADOCE 102: An Introduction

Sep 15, 1999

by Tony Scarpelli

Go to Tony Scarpelli

Program Listing

(このプログラムの実行フ© イルもダウンロード出来ます。Executable Format)
'ADOCETest.nsb
'Tony Scarpelli, 71535.306© compuserve.com
'My variables: g-global l-local
'                  n-number c-character
'                  l-logical a-array

'This test app revolves around xyEmployees

'-----------------------------------------------------
Option Explicit

Dim glTableExists, glCreateOK, glOpenOK, glAddRecOK
Dim glUpdRecOK, glDelTableOK
Dim gnNumTables, gcTableName, gcDefaultTable, recTable
Dim gaTableList(), gaFieldList(), gnNumFields
Dim gaGridSize()
Const t = True
Const f = False
gcTableName = ""
gcDefaultTable = "xyEmployees"
KeyboardStatus=0

'-----------------------------------------------------
' ADO Cursor Types
'------------------------------------------------------
Const adOpenUnspecified = -1
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3
Const DEFCursor = 0
'------------------------------------------------------
' ADO Lock Types
'------------------------------------------------------
Const adLockUnspecified = -1
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4
Const DEFLock = 1  'check what should be the default lock type
Const DEFOption = " "
'=======================

  ADDOBJECT "Label", "lblMessage", 5, 5, 224, 18
lblMessage.BorderStyle=1
lblMessage.Backcolor=vbYellow
lblMessage.Forecolor=vbBlue
  '--------
ADDOBJECT "grid","GridView", 5, 25, 226, 73
GridView.Scrollbars=3
  '--------
'This should be offscreen
ADDOBJECT "ListBox", "lstDisp", 2000, 30, 226, 66
lstDisp.Scrollbars=2
lstDisp.BorderStyle=1
  '--------
ADDOBJECT "CommandButton", "cmdListTables", 5, 105, 65, 18
  cmdListTables.Caption = "List Tables"
  cmdListTables.BackColor = vbCyan
  '--------
ADDOBJECT "CommandButton", "cmdViewRecs", 72, 105, 84, 18
  cmdViewRecs.Caption = "View Records"
  cmdViewRecs.BackColor = vbCyan
  '--------
ADDOBJECT "CommandButton", "cmdViewFields", 158, 105, 74, 18
  cmdViewFields.Caption = "View Fields"
  cmdViewFields.BackColor = vbCyan
  '--------
ADDOBJECT "CommandButton", "cmdCreateTable", 5, 130, 93, 18
  cmdCreateTable.Caption = "Create Table"
  cmdCreateTable.BackColor = vbCyan
  '--------
ADDOBJECT "CommandButton", "cmdDelTable", 130, 130, 89, 18
  cmdDelTable.Caption = "Delete Table"
  cmdDelTable.BackColor = vbCyan
  '--------
ADDOBJECT "CommandButton", "cmdAddRec", 5, 155, 93, 18
  cmdAddRec.Caption = "Add Record"
  cmdAddRec.BackColor = vbCyan
  '--------
ADDOBJECT "CommandButton", "cmdChange", 130, 155, 88, 18
  cmdChange.Caption = "Change Rec 2"
  cmdChange.BackColor = vbCyan
  '--------
ADDOBJECT "CommandButton", "cmdOpen", 5, 180, 77, 18
  cmdOpen.Caption = "Open Table"
  cmdOpen.BackColor = vbCyan
  '--------
ADDOBJECT "CommandButton", "cmdClose", 85, 180, 76, 18
  cmdClose.Caption = "Close Table"
  cmdClose.BackColor = vbCyan
  '--------
ADDOBJECT "CommandButton", "cmdQuit", 167, 180, 66, 18
  cmdQuit.Caption = "Quit"
  cmdQuit.BackColor = vbRed
  '--------
ADDOBJECT "CommandButton", "cmdListIndexes", 5, 205, 77, 18
  cmdListIndexes.Caption = "List Indexes"
  cmdListIndexes.BackColor = vbYellow
  '--------
ADDOBJECT "CommandButton", "cmdDelIndex", 130, 205, 89, 18
  cmdDelIndex.Caption = "Delete Index"
  cmdDelIndex.BackColor = vbYellow
  '--------

'-----------------------------------------------------
Sub cmdAddRec1_Click()
  'Add a test record
  AddRecord1
End Sub

Sub cmdAddRec2_Click()
  'Add a second test record
  AddRecord2
End Sub

Sub cmdAddRec_Click()
  AddRecord
End Sub

Sub cmdChange_Click()
  'Modify the second record, tests update
  ChangeRecord2
End Sub

Sub cmdClose_Click()
  'Close an open table
  CloseTable
End Sub

Sub cmdCreateTable_Click()
  'Create a test table
  CreateTable
End Sub

Sub cmdDelTable_Click()
  'Tests Drop
  DeleteTable
End Sub

Sub cmdDelIndex_Click()
  'Tests Drop
  DeleteIndex
End Sub

Sub cmdListTables_Click()
  'List all tables in MSysTables
  ListTables
End Sub

Sub cmdListIndexes_Click()
  'List all tables in MSysIndexes
  ListIndexes
End Sub

Sub cmdOpen_Click()
  'Tests open
  OpenTable
End Sub

Sub cmdQuit_Click()
  KeyboardStatus=1
  bye
End Sub

Sub cmdViewFields_Click()
  'View all the fields in a record
  ViewFields
  'GetFields
End Sub

Sub cmdViewRecs_Click()
  'View all the records in a table
  ViewRecs
End Sub

'-----------------------------------------------------
Sub Form_Load()
  glTableExists = f
  glCreateOK = f
  glOpenOK = f
  
  lblMessage = "Click on button for option"
  
End Sub

'-----------------------------------------------------
Sub ListTables()
  'List all tables in MSysTables
  lblMessage.Caption = "Getting Tables..."
  Dim rs, rc, strList, r
  glOpenOK = f
  'Clear out grid display
  GridView.Clear
  GridView.ScrollBars = 2    'Vert
  GridView.Cols = 1
  GridView.ColAlignment(-1) = 0   'left
  GridView.ColWidth(0) = 1200
  
  On Error Resume Next
  Set rs = CreateObject("adoce.recordset")
  
  rs.open "MSysTables", "", adOpenKeyset, adLockOptimistic
  
  If (Err.Number <> 0) Then
    MsgBox "An error occured while opening table." & vbCrLf & Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
  
  rc = rs.RecordCount
  gnNumTables = rc
  For r = 0 To rc - 1
    ReDim Preserve gaTableList(r)
    gaTableList(r) = rs.Fields("TableName").Value
    rs.movenext
  Next
  rs.Close
  Set rs = Nothing
  
  'Display the list in grid
  For r = 0 To gnNumTables - 1
    GridView.Rows = r + 1  'Add row
    GridView.TextMatrix(r, 0) = gaTableList(r)
  Next
  lblMessage.Caption = "ADOCE Tables in MSysTables"
End Sub

'-----------------------------------------------------
Sub ListIndexes()
  'List all tables in MSysIndexes
  lblMessage.Caption = "Getting Indexes..."
  Dim rs, rc, strList, r
  glOpenOK = f
  'Clear out grid display
  GridView.Clear
  GridView.ScrollBars = 2    'Vert
  GridView.Cols = 1
  GridView.ColAlignment(-1) = 0   'left
  GridView.ColWidth(0) = 1200
  
  On Error Resume Next
  Set rs = CreateObject("adoce.recordset")
  
  rs.open "MSysIndexes", "", adOpenKeyset, adLockOptimistic
  
  If (Err.Number <> 0) Then
    MsgBox "An error occured while opening table." & vbCrLf & Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
  
  rc = rs.RecordCount
  gnNumTables = rc
  For r = 0 To rc - 1
    ReDim Preserve gaTableList(r)
    gaTableList(r) = rs.Fields("IndexName").Value
    rs.movenext
  Next
  rs.Close
  Set rs = Nothing
  
  'Display the list in grid
  For r = 0 To gnNumTables - 1
    GridView.Rows = r + 1  'Add row
    GridView.TextMatrix(r, 0) = gaTableList(r)
  Next
  lblMessage.Caption = "ADOCE Indexes in MSysIndexes"
End Sub

'-----------------------------------------------------
Sub GetTables()
  'Put the list of tables into a global array
  Dim rs, rc, strList, r
  
  On Error Resume Next
  Set rs = CreateObject("adoce.recordset")
  
  rs.open "MSysTables", "", adOpenKeyset, adLockOptimistic
  
  If (Err.Number <> 0) Then
    MsgBox "An error occured while opening table." & vbCrLf & Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
  
  rc = rs.RecordCount
  gnNumTables = rc
  
  'Put each table name into array
  For r = 0 To rc - 1
    ReDim Preserve gaTableList(r)
    gaTableList(r) = rs.Fields("TableName").Value
    rs.movenext
  Next
  rs.Close
  Set rs = Nothing
End Sub

'-----------------------------------------------------
Sub CheckForTable()
  'Check to see if there is a table already in the list
  Dim r
  glTableExists = f
  For r = 0 To gnNumTables - 1
    If gaTableList(r) = gcTableName Then
      glTableExists = t
      Exit Sub
    End If
  Next
End Sub

'-----------------------------------------------------
Sub CreateTable()
  'Create a new table
  'First check to see if a table exists in global array
  gcTableName = gcDefaultTable
  CheckForTable
  
  'If the table exists, warn user
  If glTableExists = t Then
    MsgBox "This table already exists, you may need to delete it first.", , "Notice"
    Exit Sub
  End If
  
  On Error Resume Next
  Set recTable = CreateObject("adoce.recordset")
  
  recTable.open "CREATE TABLE " & gcTableName & " (EmployeeID text, Name text, DateHired datetime, Evaluation text)"
  
  If (Err.Number <> 0) Then
    MsgBox "An error occured while creating the table." & vbCrLf & Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
  
  recTable.Close
  ListTables
  lblMessage.Caption = "Table created!"
  
End Sub

'-----------------------------------------------------
Sub OpenTable()
  'Open a table in the global variable gcTableName
  Dim strSQL
  glOpenOK = f
  
' Setup an error handler.
  On Error Resume Next

' Open the table.
  Set recTable = CreateObject("adoce.recordset")
  
  strSQL = gcTableName
  
  'strSQL = "select * from foodfile order by descrip"

    recTable.open strSQL, "", adOpenKeyset, adLockOptimistic

' Check to see if an error occurred while opening the table.
  If (Err.Number <> 0) Then
    MsgBox "An error occurred while opening the table." & vbCrLf & _
    Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
  
  glOpenOK = t
  lblMessage.Caption = gcTableName & " opened."
  
End Sub

'-----------------------------------------------------
Sub CloseTable()
  'Close the open table
  On Error Resume Next
  
  recTable.Close
  
  If (Err.Number <> 0) Then
    MsgBox "An error occurred while opening the table." & vbCrLf & _
    Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
  
  Set recTable = Nothing
  glOpenOK = f
  GridView.Clear
  lblMessage.Caption = gcTableName & " closed."
  
End Sub

'-----------------------------------------------------
Sub AddRecord()
  'Add a new record
  
  If glOpenOK = f Then
    MsgBox "Please open table first", , "Notice"
    Exit Sub
  End If
  
  Dim lnNumRecs, cnt
  glAddRecOK = f
  
  On Error Resume Next
  
  lnNumRecs = recTable.RecordCount
  cnt = lnNumRecs + 1
  
  recTable.addnew
  
  recTable.Fields("EmployeeID") = "00" & Trim(CStr(cnt))
  recTable.Fields("Name") = "Name" & Trim(CStr(cnt))
  recTable.Fields("DateHired") = "01/0" & Trim(CStr(cnt)) & "/1999"
  recTable.Fields("Evaluation") = Trim(CStr(cnt)) & "-Hired"
  
  recTable.Update

  If (Err.Number <> 0) Then
    MsgBox "An error occurred adding a record." & vbCrLf & _
    Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
    
  glAddRecOK = t
  ViewRecs

End Sub

'-----------------------------------------------------
Sub AddRecord1()
  'Add a new test record
  If glOpenOK = f Then
    MsgBox "Please open table first", , "Notice"
    Exit Sub
  End If
  
  glAddRecOK = f
  
  On Error Resume Next
  
  recTable.addnew
  
  recTable.Fields("EmployeeID") = "001"
  recTable.Fields("Name") = "Joe Blow"
  recTable.Fields("DateHired") = "01/01/1999"
  recTable.Fields("Evaluation") = "Hired"
  
  recTable.Update

  If (Err.Number <> 0) Then
    MsgBox "An error occurred adding a record." & vbCrLf & _
    Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
    
  glAddRecOK = t
  ViewRecs

End Sub

'-----------------------------------------------------
Sub AddRecord2()
  'Add a second test record
  If glOpenOK = f Then
    MsgBox "Please open table first", , "Notice"
    Exit Sub
  End If
  
  glAddRecOK = f
  
  On Error Resume Next
  
  recTable.addnew
  
  recTable.Fields("EmployeeID") = "002"
  recTable.Fields("Name") = "Jane Doe"
  recTable.Fields("DateHired") = "02/02/1999"
  recTable.Fields("Evaluation") = "Hired with proviso"
  
  recTable.Update

  If (Err.Number <> 0) Then
    MsgBox "An error occurred adding a record." & vbCrLf & _
    Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
    
  glAddRecOK = t
  ViewRecs

End Sub

'-----------------------------------------------------
Sub ViewRecs2()
  'Display the records in a table in a list
  Dim cnt, i, lcString
  If glOpenOK = f Then
    MsgBox "Please open table first", , "Notice"
    Exit Sub
  End If
  
  If recTable.RecordCount = 0 Then
    MsgBox "There are no records in this table.", , "Notice"
    Exit Sub
  End If
  
  'Put field list into array
  GetFields

  'Set number of columns for grid & and other properties
  lstDisp.Clear

  'Put field names into top (0) row
  lcString = ""
  For i = 0 To gnNumFields - 1
    lcString = lcString & "|" & gaFieldList(i)
  Next
  lstDisp.AddItem lcString
  
  'Start at first record
  recTable.movefirst
  cnt = 1
  Do While Not recTable.EOF
    lcString = ""
    For i = 0 To gnNumFields - 1
      lcString = lcString & "|" &  recTable.Fields(gaFieldList(i)).Value
    Next
    lstDisp.AddItem lcString
    recTable.movenext
    cnt = cnt + 1
  Loop
  
End Sub

'-----------------------------------------------------
Sub ViewRecs()
  'Display the records in a table in a grid
  Dim cnt, i, lcStr, lcType
  If glOpenOK = f Then
    MsgBox "Please open table first", , "Notice"
    Exit Sub
  End If
  
  If recTable.RecordCount = 0 Then
    MsgBox "There are no records in this table.", , "Notice"
    Exit Sub
  End If
  
  lblMessage.caption = "Listing records for " & gcTableName & "..."
  
  'Put field list into array
  GetFields

  'Set number of columns for grid & and other properties
  GridView.Clear
  GridView.ScrollBars = 3           'Both Horiz & Vert
  GridView.Cols = gnNumFields       'Set # or cols
  GridView.Col = 0                  'Start at col 0
  GridView.Row = 0                  'Start at row 0
  GridView.ColSel = gnNumFields - 1 'End at the last col
  GridView.FillStyle = 1            'Repeat for all cols
  GridView.ColAlignment(-1) = 0     'Align all left
  'GridView.CellFontBold = True      'Set bold
  GridView.CellFontUnderline = True 'Set underline
  
  'Put field names into top (0) row
  For i = 0 To gnNumFields - 1
    GridView.TextMatrix(0, i) = gaFieldList(i)
  Next
  
  'Start at first record
  recTable.movefirst
  cnt = 1
  Do While Not recTable.EOF
    GridView.Rows = cnt + 1         'Add another row
    For i = 0 To gnNumFields - 1
      lcStr = recTable.Fields(gaFieldList(i)).Value
      lcType=TypeName(lcStr)
      if lcType="Null" then
        lcStr=""
      end if
      GridView.TextMatrix(cnt, i) = lcStr
    Next
    recTable.movenext
    cnt = cnt + 1
  Loop
  
  lblMessage.caption = gcTableName & " listing"
  
End Sub

'-----------------------------------------------------
Sub ChangeRecord2()
  'Modify the second record to test update
  If glOpenOK = f Then
    MsgBox "Please open table first", , "Notice"
    Exit Sub
  End If
  
  glUpdRecOK = f
  
  On Error Resume Next
  
  recTable.movefirst
  recTable.movenext
  
  recTable.Update "Evaluation", "Hired"

  If (Err.Number <> 0) Then
    MsgBox "An error occurred updating a record." & vbCrLf & _
    Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
    
  glUpdRecOK = t
  ViewRecs

End Sub

'-----------------------------------------------------
Sub DeleteTable()
  'Delete a table using Drop
  Dim llDelOK
  glDelTableOK = f
  
  If Mid(gcTableName, 1, 4) = "MSys" Then
    MsgBox "Sorry, can't delete this table.", , "Notice"
    Exit Sub
  End If
  
  If gcTableName = "" Then
    MsgBox "Please pick a table to delete.", , "Notice"
    Exit Sub
  End If
  
  llDelOK = MsgBox("Are you sure you want to delete " & gcTableName & "?", vbYesNo + vbQuestion, "Warning")
  If llDelOK = 7 Then
    Exit Sub
  End If
  
  On Error Resume Next
  Set recTable = CreateObject("adoce.recordset")
  
  recTable.open "drop table " & gcTableName
  
  If (Err.Number <> 0) Then
    MsgBox "An error occurred deleting the table." & vbCrLf & _
    Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
    
  glDelTableOK = t
  glOpenOK = f
  Set recTable = Nothing
  ListTables

End Sub

'-----------------------------------------------------
Sub DeleteIndex()
  'Delete an Index using Drop
  Dim llDelOK
  glDelTableOK = f
  
  If gcTableName = "" Then
    MsgBox "Please pick an Index to delete.", , "Notice"
    Exit Sub
  End If
  
  llDelOK = MsgBox("Are you sure you want to delete " & gcTableName & "?", vbYesNo + vbQuestion, "Warning")
  If llDelOK = 7 Then
    Exit Sub
  End If
  
  On Error Resume Next
  Set recTable = CreateObject("adoce.recordset")
  
  recTable.open "drop Index " & gcTableName
  
  If (Err.Number <> 0) Then
    MsgBox "An error occurred deleting the index." & vbCrLf & _
    Err.Number & " - " & Err.Description
    Err.Clear
    Exit Sub
  End If
    
  glDelTableOK = t
  glOpenOK = f
  Set recTable = Nothing
  ListIndexes

End Sub

'-----------------------------------------------------
Sub GridView_Click()
  'Get name of table & display it
  'List of table names kept in array gaTableList
  gcTableName = GridView.Text
  lblMessage.Caption = gcTableName
End Sub

'-----------------------------------------------------
Sub ViewFields()
  'Display all the fields in a table
  Dim n, lcString
  lcString = ""
  
  If glOpenOK = f Then
    MsgBox "Please open table first", , "Notice"
    Exit Sub
  End If
  
  If recTable.Fields.Count = 0 Then
    MsgBox "There are no fields in this table.", , "Notice"
    Exit Sub
  End If

  For n = 0 To recTable.Fields.Count - 1
    lcString = lcString & CStr(n) & " - " & recTable.Fields(n).Name & vbCrLf
  Next
  MsgBox lcString, , "List of fields"
  
End Sub

'-----------------------------------------------------
Sub GetFields()
  'Put all the fields in a table into an array
  Dim n, lcString
  lcString = ""
  
  If glOpenOK = f Then
    MsgBox "Please open table first", , "Notice"
    Exit Sub
  End If
  
  If recTable.Fields.Count = 0 Then
    MsgBox "There are no fields in this table.", , "Notice"
    Exit Sub
  End If

  For n = 0 To recTable.Fields.Count - 1
    ReDim Preserve gaFieldList(n)
    gaFieldList(n) = recTable.Fields(n).Name
    'lcString = lcString & CStr(n) & " - " & gaFieldList(n) & vbCrLf
  Next
  
  'MsgBox lcString, , "List of " & CStr(n) & " fields"
  
  gnNumFields = n
  
End Sub

'=======================
  'Test program without any controls
  
  'List all tables in MSysTables
  'ListTables
  
  'Put the tables into a global array
  'GetTables
  
  'Check to see if a table exists in global array
  'gcTableName = "xyEmployees"
  'CheckForTable
  
  'If the table exists, delete it
  'If glTableExists = t Then
  '  DeleteTable
  '  If glDelTableOK = t Then
  '    ListTables
  '  End If
  'End If
  
  'If the table doesn't exist then create it
  'CheckForTable
  'If glTableExists = f Then
  '  CreateTable
  'End If
  
  'If the table exists then open it
  'GetTables
  'CheckForTable
  'If glTableExists = t Then
  '  OpenTable
  'End If
  
  'If the table opened all right, add a record
  'If glOpenOK = t Then
  '  MsgBox "Table Opened OK", , "ADOCE Test"
  '  'CloseTable
  '  AddRecord1
  '  If glAddRecOK = t Then
  '    ViewRecs
  '    AddRecord2
  '    If glAddRecOK = t Then
  '      ViewRecs
  '      If glAddRecOK = t Then
  '        ChangeRecord2
  '        ViewRecs
  '      End If
  '    End If
  '   Else
  '    MsgBox "AddRecord failed", , "ADOCE Test"
  '  End If
  '  CloseTable
  'Else
  '  MsgBox "Table Failed to open", , "ADOCE Test"
  'End If

'=======================