Attribute VB_Name = "Module2"
Option Explicit
'Global cb As Long          'Used to store CODE4 pointer
'Global db As Long          'Used to store DATA4 pointer
'Global rc As Integer       'Used as general return code

'Global lf As String        'Line Feed
'Global fPath As String     'Full path name to data files
'Global configCode As Long  'What type of DLL being used?

'loop counters
'Global i As Integer, j As Integer

'Structure pointers -- Used by Relate examples
Dim student As Long, enrollment As Long         'DATA4
Dim classes As Long
Dim studentId As Long, firstName As Long        'FIELD4
Dim lastName As Long, studentAge As Long
Dim classCode As Long, classTitle As Long
Dim acctNo As Long, balance As Long
Global master As Long, slave As Long            'RELATE4
Global classRel As Long, enrollRel As Long
Dim studentRel As Long
Dim nameTag As Long, idTag As Long              'TAG4
Dim codeTag As Long
Dim acctTag As Long, balTag As Long


'Other vars used by Relate3 example
Dim endVal As Integer

'FIELD4 structure pointers -- Used by NewList & Others
Dim fName As Long, lname As Long, address As Long
Dim age As Long, birthdate As Long, married As Long
Dim amount As Long, comment As Long

'Structure Arrays -- Used by Various Programs
Global fieldInfo()  As FIELD4INFO
Global tagInfo() As TAG4INFO

'Other vars used by NewList Program & Others
Dim ageVal As Integer, amtVal As Double
Dim fnameStr As String, lnameStr As String
Dim addressStr As String, marriedStr As String
Dim birthdateStr As String, commentStr As String


Global Const MB_OK = 0
Global Const MB_YESNO = 4
Global Const MB_ICONSTOP = 16
Global Const MB_ICONQUESTION = 32
Global Const IDYES = 6

Sub AddNewRecord(fnameStr$, lnameStr$, addressStr$, ageVal%, birth$, marriedVal%, amountVal#, commentStr$)

  If d4appendStart(db, 0) <> r4success Then Exit Sub

  Call f4assign(fName, fnameStr)
  Call f4assign(lname, lnameStr)
  Call f4assign(address, addressStr)

  Call f4assignInt(age, ageVal)
  Call f4assign(birthdate, birth)

  If marriedVal Then
    Call f4assign(married, "T")
  Else
    Call f4assign(married, "F")
  End If

  Call f4assignDouble(amount, amountVal)
  rc = f4memoAssign(comment, commentStr)

  rc = d4append(db)

End Sub

Sub AddRecord(dbf As Long, field As Long)

   Dim buf As String

   buf = InputBox("Enter new record", "AddRecord")

   rc = d4appendStart(dbf, 0)
   Call f4assign(field, buf)
   rc = d4append(dbf)

   rc = d4unlock(dbf)
   
End Sub

Function cbError()

   If code4errorCode(cb, 0) < 0 Then
      cbError = True
   Else
      cbError = False
   End If

End Function

Function CreateDataFile(overWrite As Integer)

   Dim save As Integer

   If overWrite Then save = code4safety(cb, 0)  'OK to overwrite file
   
   InitField4
   InitTag4
   db = d4create(cb, fPath + "DATA1", fieldInfo(), tagInfo())
   
   If cbError() Or db = 0 Then
      CreateDataFile = False
      Exit Function
   End If

   fName = d4field(db, "F_NAME")                'Get field pointers
   lname = d4field(db, "L_NAME")
   address = d4field(db, "ADDRESS")
   age = d4field(db, "AGE")
   birthdate = d4field(db, "BIRTH_DATE")        'Date field
   married = d4field(db, "MARRIED")             'Logical
   amount = d4field(db, "AMOUNT")               'Numeric
   comment = d4field(db, "COMMENT")             'Memo

   If Not cbError() Then CreateDataFile = True
  
   rc = code4safety(cb, save)                   'Restore original setting

End Function

Function CreateDataOnly(overWrite As Integer)
   Dim save As Integer

   If overWrite Then save = code4safety(cb, 0)  'OK to overwrite file
   
   InitField4
   db = d4createData(cb, fPath + "DATA1", fieldInfo())
   
   If cbError() Or db = 0 Then
      CreateDataOnly = False
      Exit Function
   End If

   fName = d4field(db, "F_NAME")                'Get field pointers
   lname = d4field(db, "L_NAME")
   address = d4field(db, "ADDRESS")
   age = d4field(db, "AGE")
   birthdate = d4field(db, "BIRTH_DATE")        'Date field
   married = d4field(db, "MARRIED")             'Logical
   amount = d4field(db, "AMOUNT")               'Numeric
   comment = d4field(db, "COMMENT")             'Memo

   If Not cbError() Then CreateDataOnly = True
  
   rc = code4safety(cb, save)                   'Restore original setting

End Function

Function CreateDeleteFile%()

   Dim save As Integer

   ReDim fieldInfo(1 To 2) As FIELD4INFO        'Two fields
   
   fieldInfo(1).fName = "DUMMY"                 'Field data
   fieldInfo(1).ftype = r4str
   fieldInfo(1).flength = 10
   fieldInfo(1).fdecimals = 0
   
   fieldInfo(2).fName = "MEMO"
   fieldInfo(2).ftype = r4memo
   fieldInfo(2).flength = r4memoLen
   fieldInfo(2).fdecimals = 0
   
   save = code4safety(cb, 0)                    'Overwrite old file
   
   'Create data file only
   db = d4createData(cb, "DELETION", fieldInfo())
   
   If db = 0 Then
      rc = code4errorCode(cb, 0)                'Reset error code
      CreateDeleteFile = False
   Else
      CreateDeleteFile = True
   End If
   
   rc = code4safety(cb, save)                   'Restore original setting

End Function

Function CreateIndexDescend()

   ReDim tagInfo(1 To 4) As TAG4INFO
   Dim indPtr As Long, save As Integer

   save = code4safety(cb, 0)

   tagInfo(1).name = "NAME_TAG"
   tagInfo(1).expression = "L_NAME + F_NAME"
   tagInfo(1).descending = r4descending

   tagInfo(2).name = "ADDR_TAG"
   tagInfo(2).expression = "ADDRESS"
   tagInfo(2).descending = r4descending

   tagInfo(3).name = "AGE_TAG"
   tagInfo(3).expression = "AGE"
   tagInfo(3).descending = r4descending

   tagInfo(4).name = "DATE_TAG"
   tagInfo(4).expression = "BIRTH_DATE"
   tagInfo(4).descending = r4descending

   indPtr = i4create(db, "", tagInfo())

   If Not cbError() And indPtr > 0 Then CreateIndexDescend = True

   rc = code4safety(cb, save)

End Function

Function CreateIndexFile%()

   ReDim tagInfo(1 To 4) As TAG4INFO
   Dim indPtr As Long, save As Integer

   save = code4safety(cb, 0)

   tagInfo(1).name = "NAME_TAG"
   tagInfo(1).expression = "F_NAME + L_NAME"
   tagInfo(1).filter = ".NOT. DELETED()"
   tagInfo(1).unique = r4unique

   tagInfo(2).name = "AGE_TAG"
   tagInfo(2).expression = "AGE"
   tagInfo(2).filter = "AGE > 40"
   
   tagInfo(3).name = "AMT_TAG"
   tagInfo(3).expression = "AMOUNT"
   tagInfo(3).filter = "AMOUNT > 100"
   tagInfo(3).descending = r4descending

   tagInfo(4).name = "DATE_TAG"
   tagInfo(4).expression = "BIRTH_DATE"
   tagInfo(4).filter = ""
   
   indPtr = i4create(db, "", tagInfo())

   If Not cbError() And indPtr > 0 Then CreateIndexFile = True

   rc = code4safety(cb, save)

End Function

Function Credit(toAcct As Long, amt As Double)
    Dim newBal As Double

    Call d4tagSelect(db, acctTag)
    rc = d4seekDouble(db, toAcct)

    If rc <> r4success Then
        Credit = rc
        Exit Function
    End If

    newBal = f4double(balance) + amt

    Call f4assignDouble(balance, newBal)

    If Not cbError() Then Credit = r4success
End Function

Function Debit(fromAcct As Long, amt As Double)
    Debit = Credit(fromAcct, -amt)
End Function

Sub FindRecord(dbf As Long)

   Dim buf As String

   buf = InputBox("Enter Name to Find", "FindRecord")

   rc = d4seek(db, buf)

   If rc = r4success Then
      MsgBox "Record found"
   Else
      MsgBox "Not Found. Return code = " + Str$(rc)
   End If

End Sub

Sub GenericPrint()

   Dim fldPtr As Long

   rc = d4top(db)
   Do While rc = r4success             'Loop through each record
     For j = 1 To d4numFields(db)      'Loop through each field
        fldPtr = d4fieldJ(db, j)       'Get Field pointer
        frmUser.Print f4name(fldPtr); Tab(15); f4memoStr(fldPtr) 'Print field contents
     Next j
     frmUser.Print                       'Blank line between recs.
     rc = d4skip(db, 1)                'Go to next record
   Loop

   MsgBox "Click to Continue"

   frmUser.Cls

End Sub

Sub HowLongUntil(aMonth As Integer, aDay As Integer, title As String)

   Dim todayStandard As String, today As String, theDate As String, dow As String
   Dim julianToday As Long, julianDate As Long, days As Long
   Dim theYear As Integer

   Call date4today(todayStandard)
   Call date4format(todayStandard, today, "MMM DD/CCYY")

   frmUser.Print "Today's date is " + today

   theYear = date4year(todayStandard)
   theDate = Format$(theYear) + Format$(aMonth, "00") + Format$(aDay, "00")

   'Conver dates to julian days
   julianToday = date4long(todayStandard)
   julianDate = date4long(theDate)

   ' 'theDate' has already passed for this year, so add a year
   If julianDate < julianToday Then
      theYear = theYear + 1
      theDate = Format$(theYear) + Format$(aMonth, "00") + Format$(aDay, "00")
      julianDate = date4long(theDate)
   End If

   'Calculate the number of days to the 'theDate'
   days = julianDate - julianToday

   'Get day of week
   dow = date4cdow(theDate)

   frmUser.Print "There are " + Str$(days) + " days until " + title
   frmUser.Print "which is a " + dow + " this year"
   frmUser.Print ""

End Sub

Sub InitField4()

  ReDim fieldInfo(1 To 8) As FIELD4INFO

  fieldInfo(1).fName = "F_NAME"
  fieldInfo(1).ftype = r4str
  fieldInfo(1).flength = 10
  fieldInfo(1).fdecimals = 0

  fieldInfo(2).fName = "L_NAME"
  fieldInfo(2).ftype = r4str
  fieldInfo(2).flength = 10
  fieldInfo(2).fdecimals = 0

  fieldInfo(3).fName = "ADDRESS"
  fieldInfo(3).ftype = r4str
  fieldInfo(3).flength = 15
  fieldInfo(3).fdecimals = 0

  fieldInfo(4).fName = "AGE"
  fieldInfo(4).ftype = r4num
  fieldInfo(4).flength = 2
  fieldInfo(4).fdecimals = 0

  fieldInfo(5).fName = "BIRTH_DATE"
  fieldInfo(5).ftype = r4date
  fieldInfo(5).flength = r4dateLen
  fieldInfo(5).fdecimals = 0

  fieldInfo(6).fName = "MARRIED"
  fieldInfo(6).ftype = r4log
  fieldInfo(6).flength = r4logLen
  fieldInfo(6).fdecimals = 0

  fieldInfo(7).fName = "AMOUNT"
  fieldInfo(7).ftype = r4num
  fieldInfo(7).flength = 7
  fieldInfo(7).fdecimals = 2

  fieldInfo(8).fName = "COMMENT"
  fieldInfo(8).ftype = r4memo
  fieldInfo(8).flength = r4memoLen
  fieldInfo(8).fdecimals = 0

End Sub

Sub InitTag4()

   ReDim tagInfo(1 To 4) As TAG4INFO

   tagInfo(1).name = "NAME_TAG"
   tagInfo(1).expression = "F_NAME + L_NAME"
   tagInfo(1).filter = ".NOT. DELETED()"
   tagInfo(1).unique = r4unique

   tagInfo(2).name = "AGE_TAG"
   tagInfo(2).expression = "AGE"
   
   tagInfo(3).name = "AMT_TAG"
   tagInfo(3).expression = "AMOUNT"
   tagInfo(3).descending = r4descending

   tagInfo(4).name = "DATE_TAG"
   tagInfo(4).expression = "BIRTH_DATE"
   
   
End Sub

Sub ListData(dbf As Long, field As Long)

   Dim file As String, oldOpt As Long
   file = d4alias(dbf)

   frmUser.List2.Clear

   rc = code4optStart(cb)
   rc = d4optimize(dbf, 1)

   rc = d4top(db)
   
   If cbError() Then Exit Sub

   frmUser.List2.AddItem "File Name: " + file$
   frmUser.List2.AddItem String$(35, "-")
   frmUser.List2.AddItem ""

   Do While rc = r4success
      frmUser.List2.AddItem "Rec. #:" + Str$(d4recNo(db))
      frmUser.List2.AddItem f4str(field)
      frmUser.List2.AddItem ""
      rc = d4skip(dbf, 1)
   Loop

   rc = d4optimize(dbf, 0)
   rc = code4optSuspend(cb)
   
End Sub

Sub ListRecsRelate1()

   rc = relate4top(master)

   Do While rc = r4success
      PrintRecRelate1
      rc = relate4skip(master, 1)
   Loop
  
End Sub

Sub ListRecsRelate3(expr As String, direction As Long)

   Static querySet As Integer                   'Query count

   rc = relate4querySet(classRel, expr)
   rc = relate4sortSet(classRel, "STUDENT->L_NAME + STUDENT->F_NAME")
   rc = relate4type(enrollRel, relate4scan)

   If cbError() Then Exit Sub

   If direction > 0 Then
      rc = relate4top(classRel)
      endVal = r4eof
   Else
      rc = relate4bottom(classRel)
      endVal = r4bof
   End If

   frmUser.List2.AddItem "Relational Query # " + Str$(querySet + 1)
   frmUser.List2.AddItem expr
   frmUser.List2.AddItem String$(30, "*")
   frmUser.List2.AddItem ""

   Do While rc <> endVal
      PrintRecRelate3
      rc = relate4skip(classRel, direction)
   Loop

   frmUser.List2.AddItem ""

   querySet = querySet + 1

End Sub

Sub Main2()

   cb = code4init()                 'Initialize CodeBasic
   If cb = 0 Then
      MsgBox "code4init() failed"
      Exit Sub
   Else
      configCode = u4switch() 'Determine what type of DLL being used
      frmUser.Show (1)          'Show Form1 modally
   End If

   rc = code4initUndo(cb)     'Close everything and free resources

End Sub

Sub ModifyRecord(dbf As Long, field As Long)

   Dim buf As String
   Dim oldLockAttempts As Integer

   'Save current value of CODE4.lockAttempts, and set to one lock attempt only
   oldLockAttempts = code4lockAttempts(cb, 1)

   rc = d4lock(dbf, d4recNo(dbf))
   If rc = r4locked Then
      MsgBox "Record locked. Unable to edit"
   Else
      buf = InputBox("Enter Replacement Record", "ModifyRecord")

      Call f4assign(field, buf)

      rc = d4flush(dbf)
      rc = d4unlock(dbf)
   End If

   rc = code4lockAttempts(cb, oldLockAttempts)

End Sub

Function OpenDataFile%()

   Dim save As Integer

   save = code4errOpen(cb, 0)

   db = d4open(cb, fPath + "DATA1")
   If db = 0 Then
      InitField4
      db = d4createData(cb, "DATA1", fieldInfo())
      If cbError() Then
        OpenDataFile = False
        Exit Function
      End If
   End If
   
   fName = d4field(db, "F_NAME")              'Get field pointers
   lname = d4field(db, "L_NAME")
   address = d4field(db, "ADDRESS")
   age = d4field(db, "AGE")
   birthdate = d4field(db, "BIRTH_DATE")      'Date field
   married = d4field(db, "MARRIED")           'Logical
   amount = d4field(db, "AMOUNT")             'Numeric
   comment = d4field(db, "COMMENT")           'Memo
   
   rc = code4errOpen(cb, save)

   If Not cbError() Then OpenDataFile = True
   
End Function

Function OpenDataFileTransfer()

    db = d4open(cb, fPath + "BANK")

    If db <> 0 Then
        acctNo = d4field(db, "ACCT_NO")
        balance = d4field(db, "BALANCE")

        acctTag = d4tag(db, "ACCT_TAG")
        balTag = d4tag(db, "BAL_TAG")
    End If
         
    If Not cbError() Then
        OpenDataFileTransfer = True
    Else
        OpenDataFileTransfer = False
    End If

End Function

Function OpenFileRelate1()

   student = d4open(cb, fPath + "STUDENT")
   enrollment = d4open(cb, fPath + "ENROLL")

   If cbError() Then
      rc = code4close(cb)
      Exit Function
   End If

   nameTag = d4tag(student, "NAME")
   idTag = d4tag(enrollment, "STU_ID_TAG")
   
   If Not cbError() Then
      OpenFileRelate1 = True
   Else
      rc = code4close(cb)
   End If

End Function



Function OpenFileRelate3()

   student = d4open(cb, fPath + "STUDENT")
   enrollment = d4open(cb, fPath + "ENROLL")
   classes = d4open(cb, fPath + "CLASSES")

   If cbError() Then
      rc = code4close(cb)
      Exit Function
   End If

   studentId = d4field(student, "ID")
   firstName = d4field(student, "F_NAME")
   lastName = d4field(student, "L_NAME")
   studentAge = d4field(student, "AGE")
   classCode = d4field(classes, "CODE")
   classTitle = d4field(classes, "TITLE")

   idTag = d4tag(student, "ID_TAG")
   codeTag = d4tag(enrollment, "C_CODE_TAG")

   If cbError() Then
      rc = code4close(cb)
      Exit Function
   End If

   OpenFileRelate3 = True

End Function

Function OpenFileRelate4()

   student = d4open(cb, fPath + "STUDENT")
   enrollment = d4open(cb, fPath + "ENROLL")
   
   If cbError() Then
      rc = code4close(cb)
      Exit Function
   End If

   studentId = d4field(student, "ID")
   firstName = d4field(student, "F_NAME")
   lastName = d4field(student, "L_NAME")
   studentAge = d4field(student, "AGE")
   classCode = d4field(enrollment, "C_CODE_TAG")

   nameTag = d4tag(student, "NAME")
   idTag = d4tag(enrollment, "STU_ID_TAG")

   Call d4tagSelect(student, nameTag)

   If cbError() Then
      rc = code4close(cb)
      Exit Function
   End If

   OpenFileRelate4 = True

End Function

Function OpenLogFile()
  'Opening or creating a log file is only
  'required in Stand-Alone mode

  'Zero length string is passed as the log file name
  'so the default "C4.LOG" is used as the log file name

  'NOTE: Support for zero-length string for log file
  '      name is not currently supported.

    rc = code4logOpen(cb, "C4.LOG", "user1")

    If rc = r4noOpen Then
        rc = code4logCreate(cb, "C4.LOG", "user1")
    End If
    
    If Not cbError() Then OpenLogFile = True

End Function

Sub PrintDeleteStatus(status%, recno&)

  Dim display As String

  If status Then
    display = Str$(recno) + " - DELETED"
  Else
    display = Str$(recno) + " - NOT DELETED"
  End If

  frmUser.Print "Record #   " + display
  
End Sub

Sub PrintRecords()
    rc = d4top(db)
    While rc = r4success
        frmUser.Print "------------------------------------------"
        frmUser.Print "Account Number: " + Str$(f4long(acctNo))
        frmUser.Print "Balance       : " + Str$(f4double(balance))
        rc = d4skip(db, 1)
    Wend
End Sub

Sub PrintRecordsDescend()

   Dim y As Integer
   y = 15

   If d4top(db) <> r4success Then Exit Sub

   frmUser.Print "Display records in descending "; t4Alias(d4tagSelected(db)); " order"
   frmUser.Print String$(75, "-")
   
   Do
      lnameStr = f4str(lname)                  'Copy contents of field
      fnameStr = f4str(fName)
      addressStr = f4str(address)
      ageVal = f4int(age)
      birthdateStr = f4str(birthdate)
      marriedStr = f4str(married)
      amtVal = f4double(amount)
      commentStr = f4memoStr(comment)
      
      frmUser.Print "Name:"; Tab(y); fnameStr; " "; lnameStr
      frmUser.Print "Address:"; Tab(y); addressStr
      frmUser.Print "Age:"; Tab(y); ageVal
      frmUser.Print "Birth:"; Tab(y); birthdateStr
      frmUser.Print "Married:"; Tab(y); marriedStr
      frmUser.Print "Comment;"; Tab(y); commentStr
      frmUser.Print "Amount Pchsed:"; Tab(y); amtVal
      frmUser.Print: frmUser.Print

      rc = d4skip(db, 1)
   Loop While rc = r4success
   
   MsgBox "Click to Continue"
   frmUser.Cls

End Sub

Sub PrintRecordSeek(rc As Integer)

   Dim status As String, y As Integer
   y = 15

   Call SeekStatus(rc, status)

   lnameStr = f4str(lname)                  'Copy contents of field
   fnameStr = f4str(fName)
   addressStr = f4str(address)
   ageVal = f4int(age)
   birthdateStr = f4str(birthdate)
   marriedStr = f4str(married)
   amtVal = f4double(amount)
   commentStr = f4memoStr(comment)
   
   frmUser.Print "Seek status:"; Tab(y); status
   frmUser.Print String$(40, "-")
   frmUser.Print "Name:"; Tab(y); fnameStr; " "; lnameStr
   frmUser.Print "Address:"; Tab(y); addressStr
   frmUser.Print "Age:"; Tab(y); ageVal
   frmUser.Print "Birth:"; Tab(y); birthdateStr
   frmUser.Print "Married:"; Tab(y); marriedStr
   frmUser.Print "Comment;"; Tab(y); commentStr
   frmUser.Print "Amount Pchsed:"; Tab(y); amtVal

   MsgBox "Click to Continue"
   frmUser.Cls

End Sub

Sub PrintRecordsNewList()

   Dim x As Integer
   x = 12

  If d4top(db) <> r4success Then Exit Sub
  
  Do
    lnameStr = f4str(lname)                  'Copy contents of field
    fnameStr = f4str(fName)
    addressStr = f4str(address)
    ageVal = f4int(age)
    birthdateStr = f4str(birthdate)
    marriedStr = f4str(married)
    amtVal = f4double(amount)
    commentStr = f4memoStr(comment)

    frmUser.Print "Name:"; Tab(x); fnameStr + " " + lnameStr
    frmUser.Print "Address:"; Tab(x); addressStr
    frmUser.Print "Age:"; Tab(x); Str$(ageVal); Tab(x + 7); "Married: " + marriedStr
    frmUser.Print "Birthdate:"; Tab(x); birthdateStr
    frmUser.Print "Amount:"; Tab(x); amtVal
    frmUser.Print "Comment:"; Tab(x); commentStr
    frmUser.Print
    rc = d4skip(db, 1)

  Loop While rc = r4success

End Sub

Sub PrintRecordsStatus()

  Dim status%, recno&

  rc = d4top(db)

  Do While rc = r4success
    recno = d4recNo(db)
    status = d4deleted(db)
    Call PrintDeleteStatus(status, recno)
    rc = d4skip(db, 1)
  Loop

  frmUser.Print

End Sub

Sub PrintRecRelate1()

   Dim relation As Long, dbf As Long
   Static recno As Long

   relation = master

   frmUser.List2.AddItem "Composite Rec. #" + Str$(recno + 1)
   frmUser.List2.AddItem String$(30, "-")

   Do While relation <> 0
      dbf = relate4data(relation)
      For j = 1 To d4numFields(dbf)
         frmUser.List2.AddItem f4memoStr(d4fieldJ(dbf, j))
      Next
      rc = relate4next(relation)
   Loop

   frmUser.List2.AddItem ""
   recno = recno + 1

End Sub

Sub PrintRecRelate2(dbf As Long)
   
   Static recno As Long
   
   frmUser.List2.AddItem "Query Rec. #" + Str$(recno + 1)
   frmUser.List2.AddItem String$(30, "-")

   For j = 1 To d4numFields(dbf)
      frmUser.List2.AddItem f4memoStr(d4fieldJ(dbf, j))
   Next

   frmUser.List2.AddItem ""
   recno = recno + 1

End Sub

Sub PrintRecRelate3()

   frmUser.List2.AddItem f4str(firstName)
   frmUser.List2.AddItem f4str(lastName)
   frmUser.List2.AddItem f4str(studentId)
   frmUser.List2.AddItem f4str(studentAge)
   frmUser.List2.AddItem ""

End Sub

Sub PrintRecRelate4()

   frmUser.Print f4str(firstName)
   frmUser.Print f4str(lastName)
   frmUser.Print f4str(studentId)
   frmUser.Print f4str(studentAge)
   frmUser.Print f4str(classCode)
   frmUser.Print ""

End Sub

Sub Query(dbf As Long, expr As String, order As String)

   Dim relation As Long                         'RELATE4 pointer

   relation = relate4init(dbf)                  'Initialize the relation/query

   If relation = 0 Then Exit Sub

   rc = relate4querySet(relation, expr)         'Set query condition and sort order
   rc = relate4sortSet(relation, order)

   rc = relate4top(relation)                    'First record

   frmUser.List2.AddItem "Query: " + expr
   frmUser.List2.AddItem String$(35, "*")
   frmUser.List2.AddItem ""
   
   Do While rc = r4success                      'Print each record in set
      PrintRecRelate2 (dbf)
      rc = relate4skip(relation, 1)
   Loop

   frmUser.List2.AddItem ""

   rc = relate4free(relation, 0)

End Sub

Sub SeekRelate4(key As String)

   rc = d4seek(student, key)
   rc = relate4doAll(master)

End Sub

Sub SeekStatus(rc As Integer, status As String)

   Select Case rc
      Case r4success
         status = "r4success"
      Case r4eof
         status = "r4eof"
      Case r4after
         status = "r4after"
      Case Else
         status = "other"
   End Select

End Sub

Function SetRelation1()

   master = relate4init(student)
   
   If master = 0 Then
      SetRelation1 = False
      Exit Function
   End If

   slave = relate4createSlave(master, enrollment, "ID", idTag)
   
   rc = relate4type(slave, relate4scan)

   rc = relate4top(master)

   If rc = r4success And Not cbError() Then SetRelation1 = True

End Function

Function SetRelation3()

   classRel = relate4init(classes)

   If classRel > 0 Then enrollRel = relate4createSlave(classRel, enrollment, "CODE", codeTag)

   If enrollRel > 0 Then studentRel = relate4createSlave(enrollRel, student, "STU_ID_TAG", idTag)

   If Not cbError() Then SetRelation3 = True

End Function

Function SetRelation4()

   master = relate4init(student)
   If master > 0 Then slave = relate4createSlave(master, enrollment, "ID", idTag)

   If Not cbError() Then SetRelation4 = True

End Function

Sub Transfer(fromAcct As Long, toAcct As Long, amt As Double)
    Dim rc1 As Integer, rc2 As Integer

    rc = code4tranStart(cb)
    
    rc1 = Debit(fromAcct, amt)
    rc2 = Credit(toAcct, amt)

    If rc1 = r4success And rc2 = r4success Then
        rc = code4tranCommit(cb)
    Else
        rc = code4tranRollback(cb)
    End If

End Sub

Function ValidDate(dateS As String)

   Dim rcl As Long

   rcl = date4long(dateS)

   If rcl > 0 Then ValidDate = True

End Function