Mike Swanson
5359e7c49e
Recovered Darv's VB6 source for the Valley Wide Plastering Orders application from the D: backup drive (label "Backup", 8 TB, 5.3 TB used). This is the first time we've had the actual source — prior session only had a single frmPayroll.frm from the AD server. Three project variants identified across two snapshots: - Full-Project/ (2,129 files, 124 MB) — D:\Office-Estimates\Darv\Full\Project\ - Kingston-Project/ (2,189 files, 130 MB) — D:\Office-Estimates\Darv\Kingston\Project\ - Source/ (170 files, 559 MB) — D:\Office-Estimates\Darv\Source\ wholesale - SOURCE-HOLD/ (3 files, 1 MB) — D:\Office-Estimates\Darv\SOURCE HOLD\ Latest ORDERS_C.vbp date is 2020-06-09 (Kingston snapshot). Production Orders_10A.exe was live as of April 2024 — open question whether newer source exists on other backup drives Mike will scan next. Also includes per-category and per-keyword analysis CSVs from a WizTree file-list export, plus the analyzer script that produced them (re-runnable for the next drive's CSV). VMs (VWIN7-DW.vdi 8.3 GB + XP-for-ORDERS_copy.vdi 2.8 GB), the live VWP.mdb, and the 393 MB raw WizTree CSV stay on disk only — gitignored. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
1002 lines
24 KiB
QBasic
1002 lines
24 KiB
QBasic
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
|
|
|