home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Tool Box
/
SIMS_2.iso
/
vb_code1
/
fieldpak
/
fpdemo2e.frm
< prev
next >
Wrap
Text File
|
1993-11-09
|
20KB
|
724 lines
VERSION 2.00
Begin Form EditFrm
BorderStyle = 1 'Fixed Single
Caption = "Multi-Sortable Address Book (FieldPack demo program 2)"
ClientHeight = 2895
ClientLeft = 1380
ClientTop = 2850
ClientWidth = 7215
ClipControls = 0 'False
Height = 3585
Icon = FPDEMO2E.FRX:0000
Left = 1320
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 2895
ScaleWidth = 7215
Top = 2220
Width = 7335
Begin TextBox txtFindString
Height = 315
Left = 1320
TabIndex = 23
Top = 2460
Width = 1155
End
Begin ListBox lstSortingListBox
Height = 225
Left = 0
Sorted = -1 'True
TabIndex = 22
Top = 0
Visible = 0 'False
Width = 1545
End
Begin CommandButton cmdSort
Caption = "Sort by..."
Height = 315
Left = 5880
TabIndex = 21
Top = 300
Width = 1215
End
Begin CommandButton cmdNew
Caption = "New"
Height = 315
Left = 5880
TabIndex = 20
Top = 1080
Width = 1215
End
Begin CommandButton cmdFind
Caption = "<-- Find (in current sort field)"
Height = 315
Left = 2610
TabIndex = 19
Top = 2460
Width = 2805
End
Begin CommandButton cmdReport
Caption = "Report"
Height = 315
Left = 5880
TabIndex = 18
Top = 2460
Width = 1215
End
Begin VScrollBar vscrScroller
Height = 1755
Left = 5520
Min = 1
TabIndex = 7
Top = 600
Value = 1
Width = 255
End
Begin CommandButton cmdDelete
Caption = "Delete"
Height = 315
Left = 5880
TabIndex = 8
Top = 1500
Width = 1215
End
Begin TextBox txtPhone
Height = 315
Left = 3000
TabIndex = 6
Top = 2040
Width = 2415
End
Begin TextBox txtAreaCode
Height = 315
Left = 1320
TabIndex = 5
Top = 2040
Width = 855
End
Begin TextBox txtZip
Height = 315
Left = 4080
TabIndex = 4
Top = 1680
Width = 1335
End
Begin TextBox txtState
Height = 315
Left = 1320
TabIndex = 3
Top = 1680
Width = 855
End
Begin TextBox txtCity
Height = 315
Left = 1320
TabIndex = 2
Top = 1320
Width = 4095
End
Begin TextBox txtAddress
Height = 315
Left = 1320
TabIndex = 1
Top = 960
Width = 4095
End
Begin TextBox txtName
Height = 315
Left = 1320
TabIndex = 0
Top = 600
Width = 4095
End
Begin Label lblCurrentSortField
FontBold = -1 'True
FontItalic = -1 'True
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 225
Left = 4440
TabIndex = 25
Top = 300
Width = 1215
End
Begin Label Label9
Alignment = 1 'Right Justify
Caption = "...in sort sequence by:"
Height = 225
Left = 2400
TabIndex = 24
Top = 300
Width = 1995
End
Begin Label lblRecordID
Caption = " 0 of 0"
Height = 195
Left = 1380
TabIndex = 17
Top = 300
Width = 975
End
Begin Label Label8
Alignment = 1 'Right Justify
Caption = "Record:"
Height = 195
Left = 60
TabIndex = 16
Top = 300
Width = 1215
End
Begin Label Label7
Alignment = 1 'Right Justify
Caption = "Phone:"
Height = 195
Left = 2220
TabIndex = 15
Top = 2100
Width = 735
End
Begin Label Label6
Alignment = 1 'Right Justify
Caption = "Area Code:"
Height = 195
Left = 60
TabIndex = 14
Top = 2100
Width = 1215
End
Begin Label Label5
Alignment = 1 'Right Justify
Caption = "Zip:"
Height = 195
Left = 3420
TabIndex = 13
Top = 1740
Width = 615
End
Begin Label Label4
Alignment = 1 'Right Justify
Caption = "State:"
Height = 195
Left = 60
TabIndex = 12
Top = 1740
Width = 1215
End
Begin Label Label3
Alignment = 1 'Right Justify
Caption = "City:"
Height = 195
Left = 60
TabIndex = 11
Top = 1380
Width = 1215
End
Begin Label Label2
Alignment = 1 'Right Justify
Caption = "Address:"
Height = 195
Left = 60
TabIndex = 10
Top = 1020
Width = 1215
End
Begin Label Label1
Alignment = 1 'Right Justify
Caption = "Name:"
Height = 195
Left = 60
TabIndex = 9
Top = 660
Width = 1215
End
Begin Menu mnuFile
Caption = "&File"
Begin Menu mnuExit
Caption = "E&xit"
End
End
Begin Menu mnuHelp
Caption = "&Help"
Begin Menu mnuAbout
Caption = "&About"
End
End
End
Option Explicit
'FieldPack Demo Program 2
'
'November 1993
'
'Software Source
'Fremont, California
'tel +1(510)623-7854
'fax +1(510)651-6039
'
'Original programming, including all the
'really clever report-generation work,
'by Don Wanless
'
'Rewrite and debugging, including the
'tricky New/Delete/Change stuff, and
'pedantic commentary and variable
'renaming, by Sam Cohen
Sub AdjustScrollerRange ()
Dim i As Integer
ScrollerChangeEnabled = False
vscrScroller.Max = NumberOfRecords
i% = NumberOfRecords / 10
If i% < 1 Then i% = 1
vscrScroller.LargeChange = i%
ScrollerChangeEnabled = True
End Sub
Function BuildRecord () As String
Dim rec As String
Dim wname As String
Dim firstn As String
Dim lastn As String
Dim n As Integer
wname$ = txtName.Text
n% = DS_CountDlms(wname$, ",")
If n% = 0 Then
' no comma, so assume firstname [middle] lastname
wname$ = US_Trim(wname$)
n% = DS_CountDlms(wname$, " ")
If n% Then
lastn$ = DS_GetField(wname$, " ", n% + 1)
firstn$ = Left$(wname$, DS_FindDlm(wname$, " ", n%) - 1)
wname$ = lastn$ + ", " + firstn$
Else
' no blanks, use as is
End If
ElseIf n% = 1 Then
' one comma, so assume lastname, first..., use as is
Else
' more than one comma, ???, use as is
End If
rec$ = ""
rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_NAME, US_Proper(wname$))
rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_ADDRESS, US_Proper((txtAddress.Text)))
rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_CITY, US_Proper((txtCity.Text)))
rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_STATE, UCase((txtState.Text)))
rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_ZIP, (txtZip.Text))
rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_AREACODE, (txtAreaCode.Text))
rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_PHONE, (txtPhone.Text))
'Rearrange so that the proper sort field is in front:
rec$ = DS_GetField(rec$, FldDlm$, FirstField) + FldDlm$ + DS_RemoveField(rec$, FldDlm$, FirstField)
BuildRecord$ = rec$
End Function
Sub cmdDelete_Click ()
Dim tmp As String
If FlagNewRecordInProgress Then 'User hit "Delete" to cancel a "New" rec (which isn't really there).
FlagNewRecordInProgress = False
Else
tmp$ = DS_RemoveField(DatabaseMemoryBuffer$, RecDlm$, CurrentRecordNumber)
DatabaseMemoryBuffer$ = tmp$
cmdFind.Enabled = False
lblCurrentSortField.Enabled = False
FlagFileChanged = True
End If
NumberOfRecords = NumberOfRecords - 1
If CurrentRecordNumber = 1 Then '(code to handle boundary conditions...)
If NumberOfRecords = 0 Then
CurrentRecordNumber = 0
Else
CurrentRecordNumber = NumberOfRecords '(Show last rec if we just deleted first rec.)
End If
Else
CurrentRecordNumber = CurrentRecordNumber - 1 '(Normally, show previous record.)
End If
AdjustScrollerRange
DisplayRecord
End Sub
Sub cmdFind_Click ()
Dim i As Integer
Dim FindMe As String
UpdateIfNecessary
FindMe$ = txtFindString.Text
i% = DS_FindField(DatabaseMemoryBuffer$, RecDlm$, 1, FindMe$, 2 + 4) ' case insensitive find "equal to or beginning with"
If i% < 0 Then
i% = -i%
End If
If i% Then
CurrentRecordNumber = i%
DisplayRecord
End If
End Sub
Sub cmdNew_Click ()
'Note that this does NOT put a blank record into the database.
'Instead, it (falsely) increments "NumberOfRecords" and sets
'CurrentRecordNumber to a fictitious new record at the end
'of the database. (This is not good programming technique;
'it's dangerous to lie to yourself.)
UpdateIfNecessary
TextChangeEnabled = False
txtName.Text = ""
txtAddress.Text = ""
txtCity.Text = ""
txtState.Text = ""
txtZip.Text = ""
txtAreaCode.Text = ""
txtPhone.Text = ""
NumberOfRecords = NumberOfRecords + 1
CurrentRecordNumber = NumberOfRecords
AdjustScrollerRange
vscrScroller.Value = CurrentRecordNumber
lblRecordID.Caption = Str$(CurrentRecordNumber) + " of" + Str$(NumberOfRecords)
FlagNewRecordInProgress = True
FlagRecordChanged = False
TextChangeEnabled = True
txtName.SetFocus
End Sub
Sub cmdReport_Click ()
UpdateIfNecessary
ReportFrm.Show 1
End Sub
Sub cmdSort_Click ()
UpdateIfNecessary
txtFindString.Text = "" 'Clean up
' select sort field
SortFrm.Show 1
If SortForm_OK_or_Cancel = 1 Then
Exit Sub
End If
SortRecords
DisplayRecord
End Sub
Sub DisplayRecord ()
Dim rec As String
TextChangeEnabled = False 'Otherwise, setting values into text boxes in
'code would trigger a change event!
If CurrentRecordNumber > 0 Then
rec$ = DS_GetField(DatabaseMemoryBuffer$, RecDlm$, CurrentRecordNumber)
'Rearrange record in "normal" field order for simplicity of field extraction:
rec$ = DS_InsertField(DS_RemoveField(rec$, FldDlm$, 1), FldDlm$, FirstField, DS_GetField(rec$, FldDlm$, 1))
txtName.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_NAME)
txtAddress.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_ADDRESS)
txtCity.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_CITY)
txtState.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_STATE)
txtZip.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_ZIP)
txtAreaCode.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_AREACODE)
txtPhone.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_PHONE)
Else
txtName.Text = ""
txtAddress.Text = ""
txtCity.Text = ""
txtState.Text = ""
txtZip.Text = ""
txtAreaCode.Text = ""
txtPhone.Text = ""
NumberOfRecords = 1
CurrentRecordNumber = 1
FlagNewRecordInProgress = True
End If
lblRecordID.Caption = Str$(CurrentRecordNumber) + " of" + Str$(NumberOfRecords)
vscrScroller.Value = CurrentRecordNumber
FlagRecordChanged = False 'Initialize trigger.
TextChangeEnabled = True 'Enable trigger.
txtName.SetFocus
End Sub
Sub Form_Load ()
Dim fh As Integer
Dim rc As Integer
Dim l As Long
rc% = FP_Password("Sorry, you'll have to register FIELDPACK to get a password.")
RecDlm$ = Chr$(13) + Chr$(10) 'CRLF (Carriage-return/line-feed)
FldDlm$ = ";"
fh = FreeFile
DatabaseFileName$ = "c:\fpdemo2.dat"
Open DatabaseFileName$ For Binary As #fh
l& = LOF(fh)
If l& > 65530 Then '(actually, 65536 -- but I don't trust Microsoft...)
MsgBox "File too big (over 64KB)!", 48, "FieldPack Demo Program 2"
End
End If
DatabaseMemoryBuffer$ = String$(l&, " ") 'See the next line of code...
Get #fh, , DatabaseMemoryBuffer$ 'Read entire file contents into memory (max 64 KB!!).
Close #fh
'Normally (see SaveIntoFile procedure), there's a final CRLF, after the last piece of data;
'we'll remove it, if it's there.
NumberOfRecords = DS_CountDlms(DatabaseMemoryBuffer$, RecDlm$)
DatabaseMemoryBuffer$ = DS_RemoveField(DatabaseMemoryBuffer$, RecDlm$, NumberOfRecords + 1)
If DatabaseMemoryBuffer = "" Then NumberOfRecords = 0
AdjustScrollerRange
FirstField = 1
SortField = 1
lblCurrentSortField.Enabled = True
lblCurrentSortField.Caption = "Name"
If NumberOfRecords = 0 Then
CurrentRecordNumber = 0
Else
SortRecords 'This is redundant (see SaveIntoFile procedure), but whatthehell...
CurrentRecordNumber = 1
End If
FlagFileChanged = False
FlagRecordChanged = False
FlagNewRecordInProgress = False
EditFrm.Show 'Necessary because of the SetFocus
'call in the DisplayRecord procedure.
DisplayRecord
End Sub
Sub mnuAbout_Click ()
AboutFrm.Show 1
End Sub
Sub mnuExit_Click ()
UpdateIfNecessary
If FlagFileChanged Then
SortField = 1 'We chose to always save the file sorted by "Name."
SortRecords
SaveIntoFile
End If
Unload EditFrm 'Bye...
End Sub
Sub SaveIntoFile ()
Dim fh As Integer
Dim crlf As String
crlf$ = Chr$(13) + Chr$(10)
fh = FreeFile
Kill DatabaseFileName$ 'If we didn't do this, we couldn't shorten the file contents.
Open DatabaseFileName$ For Binary As #fh
Put #fh, , DatabaseMemoryBuffer$
Put #fh, , crlf$ 'We add a final CRLF so that text editors can read the file; each
'record appears as a line of text. See Form_Load.
Close #fh
FlagFileChanged = False 'We put this here in case you want to expand this example
'into a more sophisticated program, with a "Save" menu item
'(and maybe also "Open," "Save As," etc.)
End Sub
Sub SortRecords ()
Dim i As Integer
Dim rec As String
Dim sf As String
' sort the items using a sorted list box
' clear the list box
lstSortingListBox.Clear
' load items into list box from our buffer...
For i% = 1 To NumberOfRecords
rec$ = DS_GetField(DatabaseMemoryBuffer$, RecDlm$, i%)
'First, rearrange record in "normal" field order for simplicity of field extraction:
rec$ = DS_InsertField(DS_RemoveField(rec$, FldDlm$, 1), FldDlm$, FirstField, DS_GetField(rec$, FldDlm$, 1))
'Now, rearrange so that the newly-chosen sort field is in front:
rec$ = DS_InsertField(DS_RemoveField(rec$, FldDlm$, SortField), FldDlm$, 1, DS_GetField(rec$, FldDlm$, SortField))
lstSortingListBox.AddItem rec$
Next i%
' clear our buffer
DatabaseMemoryBuffer$ = ""
' Take records from list box (now in sort sequence) and put them back into our buffer.
For i% = 1 To NumberOfRecords
DatabaseMemoryBuffer$ = DS_PutField(DatabaseMemoryBuffer$, RecDlm$, i%, (lstSortingListBox.List(i% - 1)))
Next i%
FlagFileChanged = 1
' clear list box to give memory back
lstSortingListBox.Clear
' Record the new database field arrangement:
FirstField = SortField
' show the first record (whoever called us will then call DisplayRecord)
CurrentRecordNumber = 1
cmdFind.Enabled = True
lblCurrentSortField.Enabled = True
End Sub
Sub txtAddress_Change ()
If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtAreaCode_Change ()
If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtCity_Change ()
If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtName_Change ()
If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtPhone_Change ()
If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtState_Change ()
If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtZip_Change ()
If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub UpdateIfNecessary ()
'This routine should be called everywhere there's an indication that the user
'may be finished looking at a displayed record.
Dim rec As String
If FlagRecordChanged Then '(Whether old record or new record...)
rec$ = BuildRecord()
If (Len(rec$) < (65530 - Len(DatabaseMemoryBuffer$))) Then
DatabaseMemoryBuffer$ = DS_PutField(DatabaseMemoryBuffer$, RecDlm$, CurrentRecordNumber, rec$)
FlagFileChanged = True
cmdFind.Enabled = False
lblCurrentSortField.Enabled = False
FlagNewRecordInProgress = False
Else
MsgBox "Changes not saved -- database too large (64KB limit).", 48, "FieldPack Demo Program 2"
End If
FlagRecordChanged = False
ElseIf FlagNewRecordInProgress Then '(User had a "New" record up, but didn't enter anything.)
NumberOfRecords = NumberOfRecords - 1
CurrentRecordNumber = CurrentRecordNumber - 1
AdjustScrollerRange
FlagNewRecordInProgress = False
DisplayRecord 'Display the last record in the buffer. (If none, will put up "New" rec.)
End If
End Sub
Sub vscrScroller_Change ()
If ScrollerChangeEnabled Then UpdateIfNecessary
If vscrScroller.Value = 0 Then
CurrentRecordNumber = 1
Else
CurrentRecordNumber = vscrScroller.Value
End If
DisplayRecord
End Sub
Sub vscrScroller_Scroll ()
UpdateIfNecessary
If vscrScroller.Value = 0 Then
CurrentRecordNumber = 1
Else
CurrentRecordNumber = vscrScroller.Value
End If
DisplayRecord
End Sub