'Sample data access program by John E. Carter
'nsb© jecarter.com

'Assumptions:
'The ADODC ocx is on the PC and has been registered.
'The MS Jet engine is on the system and has been registered.

'This sample code has MINIMAL error checking.  
'Any application handling real data should check for errors on 
'every data operation.
'This code is currently more than 700 lines - 
'improvements are left as an exercise For the reader ;-)

  Dim dataConn, dataCmd, dataParam, dataRec
  Dim ARYRecords, strSQL, iCount, iRecords
  Dim tStart, tEnd, SaveError
  Dim oFirst, oLast, oAddr, oCity, oState, oDirty

Sub Form1_Load
  SaveError = 0 'flag for mising field(s) on Save
  oDirty = 0    'flag for changed fields when changing records
  btnAdd.hide   'hide until data loaded
  btnDelete.hide  'hide until data loaded
  btnSave.hide  'hide until Add clicked
  tbStatus.hide 'hide until data loaded
  tbCount.hide  'hide until data loaded
  btnData.setfocus  'start here

  AddObject "MSAdodcLib.Adodc.6", "ado1"  'need data object to open database

  
End Sub


Sub btnQuit_Click

  tbStatus.text = " "   'clear status

  If oFirst = "" And Not tbFirst.text = "" Then 'new record added but not saved
    AddRecord
  End If

  oDirty = 0  'clear flag
  CheckCurrent  'check for unsaved changes
  If oDirty > 0 Then  'if unsaved changes
    lblStatus.caption = "Record updated"  'update status
    UpdateRecord      'save changes
    Sleep 1000          'pause for display reading
    lblStatus.caption = ""
    doevents
  End If

'  dataRec.Close
'  dataConn.Close
  Set dataRec = Nothing   'clear all the data stuff
  Set dataCmd = Nothing
  Set dataConn = Nothing

  Bye 'end

End Sub

Sub btnData_Click
  Dim DSNName
  tbStatus.text= " Reading data"
  tbStatus.show
  tbCount.show
  doevents
  btnData.hide
  'DSNName is used to hold both the database type and its path.
  DSNName = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
  'If NSBasic Desktop is installed in a location other than the default
  'change the path in the following line
  DSNName = DSNName & currentPath & "\Samples\ADODemo.mdb"

  Set dataConn = CreateObject("ADODB.Connection") 'need a connection
  dataConn.ConnectionString = DSNName   'this is where to connect
  dataConn.Open   'open the connection
  strSQL = "select * from DesktopDemo"  'define the data we want
  Set dataCmd = CreateObject("ADODB.Command") 'tell it we need a command run
  dataCmd.ActiveConnection = dataConn 'tell which connection
  dataCmd.CommandType = adCmdText 'type of command
  dataCmd.CommandText = strSQL  'text of command
  dataCmd.Execute 'run it
  Set dataRec = CreateObject("ADODB.Recordset") 'create recordset to hold values
  dataRec.Open dataCmd,,adOpenStatic,adLockOptimistic 'retrieve records
  If Not(dataRec.EOF) Then  'there are some records
    ARYRecords = dataRec.GetRows  'fill the array
    iRecords = ubound(ARYRecords, 2)  'get the count of records
    tbCount.show
    tbCount.text = " " & iRecords +1 & " records" 'array begins at 0
    tbFirst.text = ARYRecords(0,0)  'read the fields of record 0
    tbLast.text = ARYRecords(1,0)
    tbAddr.text = ARYRecords(2,0)
    tbCity.text = ARYRecords(3,0)
    tbState.text = ARYRecords(4,0)
    CopyCurrent 'copy textbox text for future use
    iCount = 0  'start counter at record 0
    
    'The following lines will print all the records in an Output window
'    For iCount = 0 to iRecords
'      Print iCount & ": " & ARYRecords(0, iCount) & " / " & ARYRecords(1, iCount) & " / " & ARYRecords(2, iCount) & " / "  & ARYRecords(3, iCount) & " / "  & ARYRecords(4, iCount)
'    Next
  Else
    tbStatus.text = "error=" & err
  End If

  btnAdd.show 'now that there are records, these have a use
  btnDelete.show
  tbStatus.text = " Record " & iCount +1
  
End Sub

Sub ShowRecord(RecNum)
    tbFirst.text = ARYRecords(0,RecNum) 'load the textboxes with the specified record
    tbLast.text = ARYRecords(1,RecNum)
    tbAddr.text = ARYRecords(2,RecNum)
    tbCity.text = ARYRecords(3,RecNum)
    tbState.text = ARYRecords(4,RecNum)
End Sub


Sub btnPrevious_Click
  If SaveError = 1 Then 'Save had missing field(s)
    SaveError = 2 'keep a value to know there was an error, but don't want an infinite loop when this sub is called again
    ShowRecord(iCount)  'display the specified record
    btnPrevious_Click
  End If
  tbStatus.text = " "
  oDirty = 0
  CheckCurrent  'have any fields changed?
  If oDirty > 0 Then  'if so, save the changes
    lblStatus.caption = "Record updated"
    UpdateRecord
    Sleep 1000
    lblStatus.caption = ""
    doevents
  End If
  If iCount > 0 Then  'if past the first record, OK to move back
    iCount = iCount -1
    tbStatus.text = " Record " & iCount +1
    ShowRecord(iCount)
    CopyCurrent
  Else
    tbStatus.text = "  First record"  'otherwise, tell user we're at the first record
  End If
End Sub

Sub btnNext_Click
  If SaveError = 1 Then
    SaveError = 2
    ShowRecord(iCount)
    btnNext_Click
  End If
  tbStatus.text = " "
  oDirty = 0
  CheckCurrent
  If oDirty > 0 Then
    lblStatus.caption = "Record updated"
    UpdateRecord
    Sleep 1000
    lblStatus.caption = ""
    doevents
  End If
  If iCount < iRecords Then
    iCount = iCount +1
    tbStatus.text = " Record " & iCount +1
    ShowRecord(iCount)
    CopyCurrent
  Else
    tbStatus.text = "  Last record"
  End If
End Sub

Sub CopyCurrent

  oFirst = tbFirst.text
  oLast = tbLast.text
  oAddr = tbAddr.text
  oCity = tbCity.text
  oState = tbState.text
  
End Sub

Sub CheckCurrent

  oDirty = 0
  If Not (oFirst = tbFirst.text) Then oDirty = 1
  If Not (oLast = tbLast.text) Then oDirty = 1
  If Not (oAddr = tbAddr.text) Then oDirty = 1
  If Not (oCity = tbCity.text) Then oDirty = 1
  If Not (oState = tbState.text) Then oDirty = 1
  
  If SaveError = 2 Then oDirty = 0  'ignore test if Save had missing field(s)
  
End Sub


Sub btnFirst_Click

  tbStatus.text = " "
  If SaveError = 1 Then
    SaveError = 2
    ShowRecord(iCount)
    btnFirst_Click
  End If
  oDirty = 0
  CheckCurrent
  If oDirty > 0 Then
    lblStatus.caption = "Record updated"
    UpdateRecord
    Sleep 1000
    lblStatus.caption = ""
    doevents
  End If
  If iCount > 0 Then
    iCount = 0
    tbStatus.text = " Record " & iCount +1
    ShowRecord(iCount)
    CopyCurrent
  Else
    tbStatus.text = "  First record"
  End If

End Sub

Sub btnLast_Click
  If SaveError = 1 Then
    SaveError = 2
    ShowRecord(iCount)
    btnLast_Click
  End If
  tbStatus.text = " "
  oDirty = 0
  CheckCurrent
  If oDirty > 0 Then
    lblStatus.caption = "Record updated"
    UpdateRecord
    Sleep 1000
    lblStatus.caption = ""
    doevents
  End If
  If iCount < iRecords Then
    iCount = iRecords
    tbStatus.text = " Record " & iCount +1
    ShowRecord(iCount)
    CopyCurrent
  Else
    tbStatus.text = "  Last record"
  End If

End Sub

Sub UpdateRecord
  'This is one place that the saved data form CopyCurrent is used
  ' - to Select the record to be updated if the name Is changed
	strSQL = "UPDATE DesktopDemo SET FirstName = '" & tbFirst.text & "',"	
	strSQL = strSQL & " LastName = '" & tbLast.text & "',"		
	strSQL = strSQL & " Address = '" & tbAddr.text & "',"		
	strSQL = strSQL & " City = '" & tbCity.text & "',"		
	strSQL = strSQL & " State = '" & tbState.text & "'"		
	strSQL = strSQL & " WHERE FirstName = '" & oFirst	& "'"
	strSQL = strSQL & " AND LastName = '" & oLast & "'"

  dataCmd.ActiveConnection = dataConn
  dataCmd.CommandType = adCmdText
  dataCmd.CommandText = strSQL
  dataCmd.Execute

'  dataRec.Close
  dataConn.Close
  Set dataRec = Nothing 'clear the database stuff
  Set dataCmd = Nothing
  Set dataConn = Nothing

  btnData_Click 'reload the records - OK for our small database, need better method for large databases
  
End Sub

Sub AddRecord
  
  strSQL = "INSERT INTO DesktopDemo (FirstName, LastName, Address, City, State)"
  strSQL = strSQL & " VALUES ('" & tbFirst.text & "','" & tbLast.text & "','" & tbAddr.text & "','" & tbCity.text & "',"
  strSQL = strSQL & "'" & tbState.text & "')"

  dataCmd.CommandType = adCmdText
  dataCmd.CommandText = strSQL
  dataCmd.Execute

'  dataConn.Close
  Set dataRec = Nothing
  Set dataCmd = Nothing
  Set dataConn = Nothing

  btnData_Click

End Sub


Sub DeleteRecord
  Dim DeleteOK
  DeleteOK = MsgBox("Are you sure?", vbYesNo, "Delete Record")
  If DeleteOK = 6 Then  'user clicked Yes
    strSQL = "Delete from DesktopDemo where FirstName='" & tbFirst.text & "' and LastName= '" & tbLast.text & "'"

    dataCmd.CommandType = adCmdText
    dataCmd.CommandText = strSQL
    dataCmd.Execute

'  dataConn.Close
    Set dataRec = Nothing
    Set dataCmd = Nothing
    Set dataConn = Nothing

    btnData_Click

  Else
    Exit Sub
  End If
  
End Sub


Sub btnAdd_Click

  btnDelete.hide
  
  tbStatus.text = ""
  
  tbFirst.text = ""   'clear fields for input of new data
  tbLast.text = ""
  tbAddr.text = ""
  tbCity.text = ""
  tbState.text = ""
  CopyCurrent         'clear saved data
    
  btnSave.show        'now we can use this button
  tbFirst.setfocus
  
End Sub


Sub btnSave_Click
  Dim FieldsOK
  FieldsOK = 1
  SaveError = 0
    
  tbStatus.text = ""
  btnSave.hide
  'check for empty fields - better to check and notify on each field
  If tbFirst.text = "" Then FieldsOK = 0
  If tbLast.text = "" Then FieldsOK = 0
  If tbAddr.text = "" Then FieldsOK = 0
  If tbCity.text = "" Then FieldsOK = 0
  If tbState.text = "" Then FieldsOK = 0
  CopyCurrent
  
  If FieldsOK = 1 Then
    CopyCurrent
    AddRecord
  Else
    tbStatus.text = "  Missing field(s)"
    SaveError = 1
  End If
  
  btnDelete.show
  
End Sub

Sub btnDelete_Click
  DeleteRecord
End Sub



'This is modified from the standard Microsoft ADO definition document
'because NSB Desktop doesn't have the "Const var = value" construct

'--------------------------------------------------------------------
' Microsoft ADO
'
' (c) 1996 Microsoft Corporation.  All Rights Reserved.
'
'
'
' ADO Dimants include file for VBScript
'
'--------------------------------------------------------------------

'---- CursorTypeEnum Values ----
Dim adOpenForwardOnly
Dim adOpenKeyset
Dim adOpenDynamic
Dim adOpenStatic

'---- CursorOptionEnum Values ----
Dim adHoldRecords
Dim adMovePrevious
Dim adAddNew
Dim adDelete
Dim adUpdate
Dim adBookmark
Dim adApproxPosition
Dim adUpdateBatch
Dim adResync

'---- LockTypeEnum Values ----
Dim adLockReadOnly
Dim adLockPessimistic
Dim adLockOptimistic
Dim adLockBatchOptimistic

'---- CursorLocationEnum Values ----
Dim adUseClient
Dim adUseServer
Dim adUseClientBatch

'---- DataTypeEnum Values ----
Dim adEmpty
Dim adTinyInt
Dim adSmallInt
Dim adInteger
Dim adBigInt
Dim adUnsignedTinyInt
Dim adUnsignedSmallInt
Dim adUnsignedInt
Dim adUnsignedBigInt
Dim adSingle
Dim adDouble
Dim adCurrency
Dim adDecimal
Dim adNumeric
Dim adBoolean
Dim adError
Dim adUserDefined
Dim adVariant
Dim adIDispatch
Dim adIUnknown
Dim adGUID
Dim adDate
Dim adDBDate
Dim adDBTime
Dim adDBTimeStamp
Dim adBSTR
Dim adChar
Dim adVarChar
Dim adLongVarChar
Dim adWChar
Dim adVarWChar
Dim adLongVarWChar
Dim adBinary
Dim adVarBinary
Dim adLongVarBinary

'---- ConnectPromptEnum Values ----
Dim adPromptAlways
Dim adPromptComplete
Dim adPromptCompleteRequired
Dim adPromptNever

'---- ConnectModeEnum Values ----
Dim adModeUnknown
Dim adModeRead
Dim adModeWrite
Dim adModeReadWrite
Dim adModeShareDenyRead
Dim adModeShareDenyWrite
Dim adModeShareExclusive
Dim adModeShareDenyNone

'---- IsolationLevelEnum Values ----
Dim adXactUnspecified
Dim adXactChaos
Dim adXactReadUncommitted
Dim adXactBrowse
Dim adXactCursorStability
Dim adXactReadCommitted
Dim adXactRepeatableRead
Dim adXactSerializable
Dim adXactIsolated

'---- XactAttributeEnum Values ----
Dim adXactPollAsync
Dim adXactPollSyncPhaseOne
Dim adXactCommitRetaining
Dim adXactAbortRetaining
Dim adXactAbortAsync

'---- FieldAttributeEnum Values ----
Dim adFldBookmark
Dim adFldMayDefer
Dim adFldUpdatable
Dim adFldUnknownUpdatable
Dim adFldFixed
Dim adFldIsNullable
Dim adFldMayBeNull
Dim adFldLong
Dim adFldRowID
Dim adFldRowVersion
Dim adFldCacheDeferred

'---- EditModeEnum Values ----
Dim adEditNone
Dim adEditInProgress
Dim adEditAdd

'---- RecordStatusEnum Values ----
Dim adRecOK
Dim adRecNew
Dim adRecModified
Dim adRecDeleted
Dim adRecUnmodified
Dim adRecInvalid
Dim adRecMultipleChanges
Dim adRecPendingChanges
Dim adRecCanceled
Dim adRecCantRelease
Dim adRecConcurrencyViolation
Dim adRecIntegrityViolation
Dim adRecMaxChangesExceeded
Dim adRecObjectOpen
Dim adRecOutOfMemory
Dim adRecPermissionDenied
Dim adRecSchemaViolation
Dim adRecDBDeleted

'---- GetRowsOptionEnum Values ----
Dim adGetRowsRest

'---- PositionEnum Values ----
Dim adPosUnknown
Dim adPosBOF
Dim adPosEOF

'---- AffectEnum Values ----
Dim adAffectCurrent
Dim adAffectGroup
Dim adAffectAll

'---- FilterGroupEnum Values ----
Dim adFilterNone
Dim adFilterPendingRecords
Dim adFilterAffectedRecords
Dim adFilterFetchedRecords

'---- PropertyAttributesEnum Values ----
Dim adPropNotSupported
Dim adPropRequired
Dim adPropOptional
Dim adPropRead
Dim adPropWrite

'---- ErrorValueEnum Values ----
Dim adErrInvalidArgument
Dim adErrNoCurrentRecord
Dim adErrIllegalOperation
Dim adErrInTransaction
Dim adErrFeatureNotAvailable
Dim adErrItemNotFound
Dim adErrObjectNotSet
Dim adErrDataConversion
Dim adErrObjectClosed
Dim adErrObjectOpen
Dim adErrProviderNotFound
Dim adErrBoundToCommand

'---- ParameterAttributesEnum Values ----
Dim adParamSigned
Dim adParamNullable
Dim adParamLong

'---- ParameterDirectionEnum Values ----
Dim adParamUnknown
Dim adParamInput
Dim adParamOutput
Dim adParamInputOutput
Dim adParamReturnValue

'---- CommandTypeEnum Values ----
Dim adCmdUnknown
Dim adCmdText
Dim adCmdTable
Dim adCmdStoredProc


adOpenForwardOnly = 0
adOpenKeyset = 1
adOpenDynamic = 2
adOpenStatic = 3
adHoldRecords = &H00000100
adMovePrevious = &H00000200
adAddNew = &H01000400
adDelete = &H01000800
adUpdate = &H01008000
adBookmark = &H00002000
adApproxPosition = &H00004000
adUpdateBatch = &H00010000
adResync = &H00020000
adLockReadOnly = 1
adLockPessimistic = 2
adLockOptimistic = 3
adLockBatchOptimistic = 4
adUseClient = 1
adUseServer = 2
adUseClientBatch = 3
adEmpty = 0
adTinyInt = 16
adSmallInt = 2
adInteger = 3
adBigInt = 20
adUnsignedTinyInt = 17
adUnsignedSmallInt = 18
adUnsignedInt = 19
adUnsignedBigInt = 21
adSingle = 4
adDouble = 5
adCurrency = 6
adDecimal = 14
adNumeric = 131
adBoolean = 11
adError = 10
adUserDefined = 132
adVariant = 12
adIDispatch = 9
adIUnknown = 13
adGUID = 72
adDate = 7
adDBDate = 133
adDBTime = 134
adDBTimeStamp = 135
adBSTR = 8
adChar = 129
adVarChar = 200
adLongVarChar = 201
adWChar = 130
adVarWChar = 202
adLongVarWChar = 203
adBinary = 128
adVarBinary = 204
adLongVarBinary = 205
adPromptAlways = 1
adPromptComplete = 2
adPromptCompleteRequired = 3
adPromptNever = 4
adModeUnknown = 0
adModeRead = 1
adModeWrite = 2
adModeReadWrite = 3
adModeShareDenyRead = 4
adModeShareDenyWrite = 8
adModeShareExclusive = &Hc
adModeShareDenyNone = &H10
adXactUnspecified = &Hffffffff
adXactChaos = &H00000010
adXactReadUncommitted = &H00000100
adXactBrowse = &H00000100
adXactCursorStability = &H00001000
adXactReadCommitted = &H00001000
adXactRepeatableRead = &H00010000
adXactSerializable = &H00100000
adXactIsolated = &H00100000
adXactPollAsync = 2
adXactPollSyncPhaseOne = 4
adXactCommitRetaining = &H00020000
adXactAbortRetaining = &H00040000
adXactAbortAsync = &H00080000
adFldBookmark = &H00000001
adFldMayDefer = &H00000002
adFldUpdatable = &H00000004
adFldUnknownUpdatable = &H00000008
adFldFixed = &H00000010
adFldIsNullable = &H00000020
adFldMayBeNull = &H00000040
adFldLong = &H00000080
adFldRowID = &H00000100
adFldRowVersion = &H00000200
adFldCacheDeferred = &H00001000
adEditNone = &H0000
adEditInProgress = &H0001
adEditAdd = &H0002
adRecOK = &H0000000
adRecNew = &H0000001
adRecModified = &H0000002
adRecDeleted = &H0000004
adRecUnmodified = &H0000008
adRecInvalid = &H0000010
adRecMultipleChanges = &H0000040
adRecPendingChanges = &H0000080
adRecCanceled = &H0000100
adRecCantRelease = &H0000400
adRecConcurrencyViolation = &H0000800
adRecIntegrityViolation = &H0001000
adRecMaxChangesExceeded = &H0002000
adRecObjectOpen = &H0004000
adRecOutOfMemory = &H0008000
adRecPermissionDenied = &H0010000
adRecSchemaViolation = &H0020000
adRecDBDeleted = &H0040000
adGetRowsRest = -1
adPosUnknown = -1
adPosBOF = -2
adPosEOF = -3
adAffectCurrent = 1
adAffectGroup = 2
adAffectAll = 3
adFilterNone = 0
adFilterPendingRecords = 1
adFilterAffectedRecords = 2
adFilterFetchedRecords = 3
adPropNotSupported = &H0000
adPropRequired = &H0001
adPropOptional = &H0002
adPropRead = &H0200
adPropWrite = &H0400
adErrInvalidArgument = &Hbb9
adErrNoCurrentRecord = &Hbcd
adErrIllegalOperation = &Hc93
adErrInTransaction = &Hcae
adErrFeatureNotAvailable = &Hcb3
adErrItemNotFound = &Hcc1
adErrObjectNotSet = &Hd5c
adErrDataConversion = &Hd5d
adErrObjectClosed = &He78
adErrObjectOpen = &He79
adErrProviderNotFound = &He7a
adErrBoundToCommand = &He7b
adParamSigned = &H0010
adParamNullable = &H0040
adParamLong = &H0080
adParamUnknown = &H0000
adParamInput = &H0001
adParamOutput = &H0002
adParamInputOutput = &H0003
adParamReturnValue = &H0004
adCmdUnknown = 0
adCmdText = &H0001
adCmdTable = &H0002
adCmdStoredProc = &H0004