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>
924 lines
24 KiB
Plaintext
924 lines
24 KiB
Plaintext
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
|
|
|