azcomputerguru/claudetools
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(valleywide): recover VWP Orders VB6 source from D: backup drive

Browse Source 
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>
This commit is contained in:
Mike Swanson
2026-05-16 17:36:02 -07:00
parent 7386460f55
commit 5359e7c49e
4426 changed files with 4478036 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

923
clients/valleywide/app-modernization/source-code/Source/History/User.frm Normal file
View File

@@ -0,0 +1,923 @@
VERSION 5.00
Begin VB.Form frmUser
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "CodeBase 6.0 Basic User's Guide Examples"
ClientHeight = 6210
ClientLeft = 1650
ClientTop = 1440
ClientWidth = 6420
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
LinkTopic = "Form1"
PaletteMode = 1 'UseZOrder
ScaleHeight = 6210
ScaleWidth = 6420
Begin VB.ListBox List2
Appearance = 0 'Flat
Height = 225
Left = 5580
TabIndex = 1
Top = 5712
Visible = 0 'False
Width = 735
End
Begin VB.ListBox List1
Appearance = 0 'Flat
Height = 225
Left = 5580
TabIndex = 0
Top = 5520
Width = 735
End
End
Attribute VB_Name = "frmUser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim bStandAlone, bClientServer As Integer
Private Sub Form_Load()
Dim rc As Integer
lf = Chr$(10) + Chr$(13)
configCode = u4switch()
'By default, look for data files in the EXAMPLES
'directory under stand-alone, and the server's
'executing directory under client/server
If configCode And &H80 Then
bStandAlone = True 'stand-alone
fPath = App.Path + "\"
Else
bClientServer = True
fPath = "" 'client/server
End If
'Attempt a connection under client/server using all
'default values. Change these settings as needed
If bClientServer Then
rc = code4connect(cb, "", "", "", "", "")
If rc < 0 Then
MsgBox "Cannot continue without Server connection." + lf + "Check the 'code4connect()' function in the" + lf + "Form Load event of USER.FRM", MB_OK + MB_ICONSTOP
Exit Sub
End If
End If
List1.AddItem "Append"
List1.AddItem "CopyData"
List1.AddItem "CopyData2"
List1.AddItem "CustList"
List1.AddItem "DataInfo"
List1.AddItem "Date"
List1.AddItem "Deletion"
List1.AddItem "Descend"
List1.AddItem "Multi"
List1.AddItem "NewList"
List1.AddItem "NewList2"
List1.AddItem "NoGroup"
List1.AddItem "NoGroup2"
List1.AddItem "Relate1"
List1.AddItem "Relate2"
List1.AddItem "Relate3"
List1.AddItem "Relate4"
List1.AddItem "Seeker"
List1.AddItem "ShowData"
List1.AddItem "ShowData2"
List1.AddItem "ShowData3"
List1.AddItem "Transfer"
End Sub
Private Sub Form_Resize()
Dim listHt As Integer, listWd As Integer
Dim listTp As Integer, list1Lft As Integer, list2Lft As Integer
listHt = Form1.Height * 0.7
listWd = Form1.Width * 0.32
listTp = Form1.ScaleHeight * 0.95 - listHt
list1Lft = Form1.Width * 0.95 - listWd
list2Lft = Form1.ScaleWidth * 0.05
List1.Height = listHt
List1.Width = listWd
List1.Top = listTp
List1.Left = list1Lft
List2.Height = listHt
List2.Width = listWd
List2.Top = listTp
List2.Left = list2Lft
End Sub
Private Sub List1_DblClick()
'FIELD4 pointers
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
'TAG4 pointers
Dim nameTag As Long, ageTag As Long, amtTag As Long, birthTag As Long
Dim addrTag As Long
'INDEX4 pointers
Dim ind1 As Long
'Field value holders
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
'Others
Dim fldArray As Long, tagArray As Long
Dim fileName As String, db2 As Long
Dim save1 As Integer, save2 As Integer, save3 As Integer, save4 As Integer, save5 As Integer
Dim rc1 As Integer, rc2 As Integer
Cls
List2.Visible = False
Select Case List1.Text
Case "Append"
'Append sample code
Dim dbTo As Long, dbFrom As Long
Dim infoTo As Long, infoFrom As Long
Dim rcl As Long
rc = code4optimize(cb, 1)
rc = code4optimizeWrite(cb, 1)
rcl = code4memStartMax(cb, 262140)
dbTo = d4open(cb, fPath + "TO_DBF")
dbFrom = d4open(cb, fPath + "FROM_DBF")
Print "Record count TO_DBF: "; d4recCount(dbTo)
If cbError() Then Exit Sub
rc = code4optStart(cb)
infoTo = d4field(dbTo, "INFO")
infoFrom = d4field(dbFrom, "INFO")
rc = code4lockAttempts(cb, 1)
rc1 = d4lockFile(dbTo)
rc2 = d4lockFile(dbFrom)
If rc1 Or rc2 Then
MsgBox "Locking Failed"
Exit Sub
End If
rc = d4top(dbFrom)
Do While rc = r4success
rc = d4appendStart(dbTo, 0)
Call f4assignField(infoTo, infoFrom)
rc = d4append(dbTo)
rc = d4skip(dbFrom, 1)
Loop
rc = d4unlock(dbTo)
rc = d4unlock(dbFrom)
Print "Record count TO_DBF: "; d4recCount(dbTo)
rc = code4close(cb)
Case "CopyData"
'CopyData sample code
fileName = InputBox$("Enter file name to copy", "CopyData", "DATA1")
If fileName = "" Then Exit Sub
db = d4open(cb, fPath + fileName) 'Open original
If cbError() Then Exit Sub 'Check for error
save1 = code4safety(cb, 0) 'Overwrite existing file
fldArray = d4fieldInfo(db) 'Get 'C' field info
db2 = d4createCB(cb, fPath + "DATA2", ByVal fldArray, ByVal 0&)
If db2 > 0 Then MsgBox "Successful File copy"
Call u4free(fldArray) 'Free field info
rc = code4close(cb)
rc = code4safety(cb, save1) 'Reset to initial status
Case "CopyData2"
'CopyData2 sample code
save1 = code4autoOpen(cb, 0)
save2 = code4safety(cb, 0)
fileName = InputBox$("Enter file name to copy", "CopyData", "DATA1")
If fileName = "" Then Exit Sub
db = d4open(cb, fPath + fileName) 'Open source data file
If cbError() Then Exit Sub
ind1 = i4open(db, "") 'Open index
If cbError() Then 'Check for error
rc = code4close(cb)
Exit Sub
End If
fldArray = d4fieldInfo(db) 'Get 'C' field and tag info
tagArray = i4tagInfo(ind1)
db2 = d4createCB(cb, fPath + "DATA3", ByVal fldArray, ByVal tagArray)
If db2 > 0 Then MsgBox "Successful File copy"
Call u4free(fldArray) 'Free field info
Call u4free(tagArray) 'Free tag info
rc = code4close(cb)
rc = code4autoOpen(cb, save1) 'Reset to initial status
rc = code4safety(cb, save2)
Case "CustList"
'CustList sample code
db = d4open(cb, fPath + "DATA1") 'Open file
If code4errorCode(cb, 0) < 0 Then 'Check & reset errror code
rc = code4close(cb)
Exit Sub
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 d4top(db) = r4success Then
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)
Print "Name: "; fnameStr; " "; lnameStr
Print "Address: "; addressStr; " "
Print "Age: "; ageVal; Space(5); "Married: "; marriedStr
Print "Amount: "; amtVal
Print "Comment: "; commentStr
Print
rc = d4skip(db, 1)
Loop While rc = r4success
Else
If d4recCount(db) = 0 Then Print "No records in data file"
End If
rc = code4close(cb)
Case "DataInfo"
'DataInfo sample code
Dim dbname As String, fldRef As Long, y As Integer
y = 17
dbname = InputBox$("Enter Name of File to Examine", "Open File", "DATA1")
If dbname = "" Then Exit Sub
db = d4open(cb, fPath + dbname)
If cbError() Then Exit Sub 'Check for error
Print "Data File:"; Tab(y); dbname 'Print data file information
Print "Alias:"; Tab(y); d4alias(db)
Print "Record Count:"; Tab(y); d4recCount(db)
Print "Record Length:"; Tab(y); d4recWidth(db)
Print "Field Count:"; Tab(y); d4numFields(db)
List2.Visible = True
List2.Clear
For i = 1 To d4numFields(db) 'Loop through each field
fldRef = d4fieldJ(db, i) 'Get next field pointer
List2.AddItem "Field " + Str$(i) 'Add field info
List2.AddItem f4name(fldRef)
List2.AddItem Chr$(f4type(fldRef))
List2.AddItem Str$(f4len(fldRef))
List2.AddItem Str$(f4decimals(fldRef))
List2.AddItem ""
Next i
rc = code4close(cb)
Case "Date"
'Date sample code
Dim request As String, standard As String
Dim birth As String
request = "Please enter your birthday" + lf
request = request + "in MMM DD/CCYY format"
request = request + lf + "eg Dec 23/1993"
Call HowLongUntil(12, 25, "Christmas")
Do
birth = InputBox$(request, "Date", "Jan 01/1980")
If birth = "" Then Exit Sub
Call date4init(standard, birth, "MMM DD/CCYY")
Loop While Not ValidDate(standard)
Call HowLongUntil(date4month(standard), date4day(standard), "your next birthday")
Case "Deletion"
'Deletion sample code
Dim count As Integer
'Create test file
If Not CreateDeleteFile() Then Exit Sub
'Append 5 blank records
For i = 1 To 5
rc = d4appendBlank(db)
Next i
PrintRecordsStatus 'Print status of records
rc = d4go(db, 3) 'Go to record 3
Call d4delete(db) 'Delete the record
rc = d4go(db, 1)
Call d4delete(db)
rc = d4go(db, 4)
Call d4delete(db)
PrintRecordsStatus
rc = d4go(db, 3)
Call d4recall(db)
PrintRecordsStatus
rc = d4pack(db) 'Remove deleted records
rc = d4memoCompress(db) 'Compress memo file
PrintRecordsStatus
rc = code4close(cb)
Case "Descend"
'Descend sample Code
'Note: This example has been modified from the printed
' documentation to accomodate the fact that in
' client/server applications, a production index
' file cannot be re-created over an existing file,
' as can be done in stand-alone applications.
' Refer to the i4create() function in the
' Reference Guide for more information.
save1 = code4autoOpen(cb, 0) 'no effect under client/server
save2 = code4accessMode(cb, OPEN4DENY_RW)
If bStandAlone Then
rc = OpenDataFile()
Else
rc = CreateDataOnly(True)
End If
If rc Then
If d4recCount(db) = 0 Then
Call AddNewRecord("Sarah", "Webber", "132-32 St.", 32, "19610523", True, 147.99, "New Customer")
Call AddNewRecord("John", "Albridge", "1232-76 Ave.", 55, "19381212", False, 98.99, "")
End If
If CreateIndexDescend() Then
nameTag = d4tag(db, "NAME_TAG")
addrTag = d4tag(db, "ADDR_TAG")
ageTag = d4tag(db, "AGE_TAG")
birthTag = d4tag(db, "DATE_TAG")
Call d4tagSelect(db, nameTag)
PrintRecordsDescend
Call d4tagSelect(db, addrTag)
PrintRecordsDescend
Call d4tagSelect(db, ageTag)
PrintRecordsDescend
Call d4tagSelect(db, birthTag)
PrintRecordsDescend
Else
rc = code4errorCode(cb, 0)
End If
Else
rc = code4errorCode(cb, 0)
End If
rc = code4autoOpen(cb, save1)
rc = code4accessMode(cb, save2)
rc = code4close(cb)
Case "Multi"
'Multi sample code
Dim opt As String, choice As String
save1 = code4accessMode(cb, OPEN4DENY_NONE) 'Open in shared mode
save2 = code4readOnly(cb, 0) 'Read and Write
save3 = code4readLock(cb, 0) 'Don't lock when reading
save4 = code4lockAttempts(cb, WAIT4EVER) 'Try forever on locks
save5 = code4lockEnforce(cb, 1) 'lock when modifying record
db = d4open(cb, fPath + "NAMES")
If code4errorCode(cb, 0) < 0 Then Exit Sub
fName = d4field(db, "NAME")
nameTag = d4tag(db, "NAME")
Call d4tagSelect(db, nameTag)
opt$ = "Enter a Command:" + lf
opt$ = opt$ + "'a', 'f', 'l', 'm', or 'x'"
rc = d4top(db)
Do
Cls
rc = code4errorCode(cb, 0)
Print "Record #:"; d4recNo(db); Tab(25); "Name: "; f4str(fName)
Print
choice$ = InputBox(opt$, "Multi")
Select Case choice$
Case "a", "A"
Call AddRecord(db, fName)
Case "f", "F"
Call FindRecord(db)
Case "l", "L"
Call ListData(db, fName)
List2.Visible = True
Exit Do
Case "m", "M"
Call ModifyRecord(db, fName)
Case "x", "X", ""
rc = code4close(cb)
Cls
Exit Do
Case Else
MsgBox "Invalid Option", MB_OK, "Error"
End Select
Loop
rc = code4accessMode(cb, save1)
rc = code4readOnly(cb, save2)
rc = code4readLock(cb, save3)
rc = code4lockAttempts(cb, save4)
rc = code4lockEnforce(cb, save5)
Case "NewList"
'NewList sample code
save1 = code4errOpen(cb, 0) 'Disable error message
save2 = code4safety(cb, 0) 'Disable overwrite safety
If Not OpenDataFile() Then Exit Sub 'Open the file
If d4recCount(db) > 0 Then 'Not a new file
PrintRecordsNewList 'Print Records
Else
Call AddNewRecord("Sarah", "Webber", "132-32 St.", 32, "19610523", True, 147.99, "New Customer")
Call AddNewRecord("John", "Albridge", "1232-76 Ave.", 55, "19381212", False, 98.99, "")
PrintRecordsNewList
End If 'Add records, then print
rc = code4errOpen(cb, save1) 'Restore initial settings
rc = code4safety(cb, save2)
rc = code4close(cb) 'Close files
Case "NewList2"
'NewList2 sample code
Dim overWrite As Integer
overWrite = True
'Create the data and index file
If Not CreateDataFile(overWrite) Then Exit Sub
'Get TAG4 pointers
nameTag = d4tag(db, "NAME_TAG")
ageTag = d4tag(db, "AGE_TAG")
amtTag = d4tag(db, "AMT_TAG")
Call AddNewRecord("Sarah", "Webber", "132-32 St.", 32, "19610523", True, 147.99, "New Customer")
Call AddNewRecord("John", "Albridge", "1232-76 Ave.", 55, "19381212", False, 98.99, "")
Print "Natural Order:"
PrintRecordsNewList
Print
Print "Sorted by Name:"
Call d4tagSelect(db, nameTag)
PrintRecordsNewList
'And so on...
rc = code4close(cb) 'Close files
Case "NoGroup"
'NoGroup sample code
'Note: This example has been modified from the printed
' documentation to accomodate the fact that in
' client/server applications, a production index
' file cannot be re-created over an existing file,
' as can be done in stand-alone applications.
' Refer to the i4create() function in the
' Reference Guide for more information.
rc1 = MsgBox("Are you using a CodeBase Clipper DLL?", MB_YESNO + MB_ICONQUESTION, "NoGroup")
save1 = code4autoOpen(cb, 0)
save2 = code4safety(cb, 0)
save3 = code4accessMode(cb, OPEN4DENY_RW)
If bStandAlone Then
rc2 = OpenDataFile()
Else
rc2 = CreateDataOnly(True)
End If
If rc2 Then
InitTag4
ind1 = i4create(db, "", tagInfo())
If ind1 > 0 Then
If rc1 = IDYES Then
MsgBox "Index created with no Group file"
Else
MsgBox "Index created"
End If
Else
rc = code4errorCode(cb, 0)
End If
Else
rc = code4errorCode(cb, 0)
End If
rc = code4close(cb)
rc = code4autoOpen(cb, save1)
rc = code4safety(cb, save2)
rc = code4accessMode(cb, save3)
rc = code4accessMode(cb, save1)
Case "NoGroup2"
'NoGroup2 sample code
rc = MsgBox("Are you using a CodeBase Clipper DLL?", MB_YESNO + MB_ICONQUESTION, "NoGroup")
If rc <> IDYES Then
MsgBox "Cannot continue this example"
Exit Sub
End If
save1 = code4autoOpen(cb, 0)
save2 = code4safety(cb, 0)
If OpenDataFile() Then
InitTag4
nameTag = t4open(db, "NAME")
addrTag = t4open(db, "ADDRESS")
ageTag = t4open(db, "AGE")
If cbError() Then
rc = code4errorCode(cb, 0)
Else
Call d4tagSelect(db, nameTag)
GenericPrint
End If
Else
rc = code4errorCode(cb, 0)
End If
rc = d4close(db)
rc = code4autoOpen(cb, save1)
rc = code4autoOpen(cb, save2)
Case "Relate1"
'Relation1 sample code
If Not OpenFileRelate1() Then Exit Sub
If SetRelation1() Then
List2.Visible = True
List2.Clear
ListRecsRelate1
rc = code4unlock(cb)
rc = relate4free(master, 0)
End If
rc = code4close(cb)
Case "Relate2"
'Relation2 sample code
db = d4open(cb, fPath + "STUDENT")
If cbError() Then Exit Sub
List2.Visible = True
List2.Clear
Call Query(db, "AGE > 30", "")
Call Query(db, "UPPER(L_NAME) = 'MILLER'", "L_NAME + F_NAME")
rc = code4close(cb)
Case "Relate3"
'Relate3 sample code
List2.Clear
If Not OpenFileRelate3() Then Exit Sub
If SetRelation3() Then
Call ListRecsRelate3("CODE = 'MATH114 '", 1)
Call ListRecsRelate3("CODE = 'CMPT411 '", -1)
List2.Visible = True
List2.Refresh
rc = code4unlock(cb)
rc = relate4free(classRel, 0)
End If
rc = code4close(cb)
Case "Relate4"
'Relate4 sample code
If Not OpenFileRelate4() Then Exit Sub
If SetRelation4() Then
' <--- 15 ---><--- 15 --->
Call SeekRelate4("Tyler Harvey ")
Print "Seek #1"
PrintRecRelate4
Print
Print "Seek #2"
Call SeekRelate4("Miller Albert ")
PrintRecRelate4
End If
rc = code4close(cb)
Case "Seeker"
'Seeker sample code
If Not CreateDataFile(True) Then Exit Sub
If d4recCount(db) = 0 Then
Call AddNewRecord("Sarah", "Webber", "132-32 St.", 32, "19610523", True, 147.99, "New Customer")
Call AddNewRecord("John", "Albridge", "1232-76 Ave.", 55, "19381212", False, 98.99, "")
End If
'Get TAG4 pointers
nameTag = d4tag(db, "NAME_TAG")
amtTag = d4tag(db, "AMT_TAG")
birthTag = d4tag(db, "DATE_TAG")
Call d4tagSelect(db, nameTag)
' 12345678901234567890 Full Key, 20 characters
rc = d4seek(db, "Sarah Webber ")
PrintRecordSeek (rc)
rc = d4seek(db, "Sar") 'Partial Key
PrintRecordSeek (rc)
rc = d4seek(db, "Sar ") 'Exact Match
PrintRecordSeek (rc)
Call d4tagSelect(db, birthTag)
rc = d4seek(db, "19381212")
PrintRecordSeek (rc)
Call d4tagSelect(db, amtTag)
rc = d4seekDouble(db, 35.75)
PrintRecordSeek (rc)
rc = d4seek(db, "250.75")
PrintRecordSeek (rc)
'The following code finds all the occurrences of John Albridge in the tag
Call d4tagSelect(db, nameTag)
rc = d4seekNext(db, "John Albridge ")
Do Until rc <> r4success
PrintRecordSeek (rc)
rc = d4seekNext(db, "John Albridge ")
Loop
rc = code4close(cb)
Case "ShowData"
'ShowData sample code
Dim fldPtr As Long
db = d4open(cb, fPath + "SHOWDATA") 'Open file
If db = 0 Then
MsgBox "Open Failed"
rc = code4errorCode(cb, 0) 'Reset error code
Exit Sub
End If
rc = d4top(db)
For i = 1 To d4recCount(db) 'Loop through records
For j = 1 To d4numFields(db) 'Loop through each field
fldPtr = d4fieldJ(db, j) 'Get Field pointer
Print f4memoStr(fldPtr) 'Print field contents
Next j
Print 'Blank line between recs.
rc = d4skip(db, 1) 'Go to next record
Next i
rc = d4close(db) 'Close file
Case "ShowData2"
'ShowData2 sample code
Dim tagPtr As Long, DbfName As String
DbfName = InputBox$("Enter File Name", "ShowData2", "DATA1")
If RTrim$(DbfName) = "" Then Exit Sub
db = d4open(cb, fPath + DbfName) 'Open file
If db = 0 Then
rc = code4errorCode(cb, 0) 'Reset error code
Exit Sub
End If
Print "Natural Order"
Print
GenericPrint 'Natural Order
tagPtr = d4tagNext(db, 0&) 'Get first tag, if any
Do Until tagPtr = 0
Call d4tagSelect(db, tagPtr) 'Select ordering
Print "Datafile sorted by tag: "; t4Alias(d4tagSelected(db))
Print
GenericPrint
tagPtr = d4tagNext(db, tagPtr) 'Look for next tag
Loop
rc = d4close(db) 'Close file
Case "ShowData3"
'ShowData3 sample code
'Note: This example has been modified from the printed
' documentation to accomodate the fact that in
' client/server applications, a production index
' file cannot be re-created over an existing file,
' as can be done in stand-alone applications.
' Refer to the i4create() function in the
' Reference Guide for more information.
save1 = code4autoOpen(cb, 0)
If bStandAlone Then
save2 = code4errOpen(cb, 0)
Else
save2 = code4errCreate(cb, 0)
End If
save3 = code4accessMode(cb, OPEN4DENY_RW) 'Open exclusively so production
'index file can be created with
'i4create
If bStandAlone Then
rc = OpenDataFile()
Else
rc = CreateDataOnly(True)
End If
If rc Then
If d4recCount(db) = 0 Then
Call AddNewRecord("Sarah", "Webber", "132-32 St.", 32, "19610523", True, 147.99, "New Customer")
Call AddNewRecord("John", "Albridge", "1232-76 Ave.", 55, "19381212", False, 98.99, "")
End If
If CreateIndexFile() Then
tagPtr = d4tagNext(db, 0&) 'Get first tag, if any
Do Until tagPtr = 0
Call d4tagSelect(db, tagPtr) 'Select ordering
Print "Datafile sorted by tag: "; t4Alias(d4tagSelected(db))
Print "With filter: "; t4filter(d4tagSelected(db))
Print
GenericPrint
tagPtr = d4tagNext(db, tagPtr) 'Look for next tag
Loop
End If
End If
rc = code4autoOpen(cb, save1) 'Restore initial settings
If bStandAlone Then
rc = code4errOpen(cb, save2)
Else
rc = code4errCreate(cb, save2)
End If
rc = code4accessMode(cb, save3)
rc = code4close(cb)
Case "Transfer"
'Transfer sample code
rc = code4errOpen(cb, 0) 'Suppress errors when opening files
rc = code4safety(cb, 0)
rc = code4lockAttempts(cb, 5)
If u4switch() And &H80 Then 'Stand-alone
If Not OpenLogFile() Then Exit Sub
End If
If Not OpenDataFileTransfer() Then Exit Sub
PrintRecords
'The account number 56789 doesn't exist in the data file
'the transfer is aborted and the data file is not changed
Call Transfer(12345, 56789, 200#)
PrintRecords
'Both accounts exist so the transfer is completed and
'the data file is updated
Call Transfer(12345, 55555, 150.5)
PrintRecords
rc = code4close(cb)
End Select
End Sub