Programmer 7500

home *** CD-ROM | disk | FTP | other *** search

/ Programmer 7500 / MAX_PROGRAMMERS.iso / VISUAL_B / CODIGO_1 / FOX_ADR / ADR_FORM.FRM (.txt) < prev next >

Wrap

Visual Basic Form | 1993-08-26 | 19.7 KB | 688 lines

VERSION 2.00 Begin Form adr_form Caption = "Address Book" ClientHeight = 6240 ClientLeft = 2145 ClientTop = 2250 ClientWidth = 8880 Height = 6645 Icon = ADR_FORM.FRX:0000 Left = 2085 LinkTopic = "Form1" ScaleHeight = 6240 ScaleWidth = 8880 Top = 1905 Width = 9000 Begin CommandButton last_but Caption = "Las&t" Height = 495 Left = 2580 TabIndex = 33 Top = 5640 Width = 675 End Begin CommandButton first_but Caption = "F&irst" Height = 495 Left = 240 TabIndex = 32 Top = 5640 Width = 675 End Begin CommandButton list_but Caption = "&List" Height = 495 Left = 4140 TabIndex = 28 Top = 5640 Width = 675 End Begin CheckBox Action_needed Caption = "&Action needed" Height = 255 Left = 1500 TabIndex = 27 Top = 780 Width = 1635 End Begin CheckBox action_check Caption = "S&how outstanding action only" Height = 375 Left = 240 TabIndex = 26 Top = 5160 Width = 2835 End Begin OptionButton order_option Caption = "Post &code" Height = 375 Index = 0 Left = 180 TabIndex = 24 Top = 4620 Width = 1215 End Begin OptionButton order_option Caption = "S&urname" Height = 375 Index = 1 Left = 180 TabIndex = 23 Top = 4260 Width = 1215 End Begin CommandButton pack_but Caption = "Pac&k" Height = 495 Left = 6480 TabIndex = 21 Top = 5640 Width = 675 End Begin CommandButton del_but Caption = "&Delete" Height = 495 Left = 7260 TabIndex = 20 Top = 5640 Width = 675 End Begin CommandButton new_but Caption = "Ne&w" Height = 495 Left = 4920 TabIndex = 19 Top = 5640 Width = 675 End Begin CommandButton save_but Caption = "&Save" Height = 495 Left = 5700 TabIndex = 18 Top = 5640 Width = 675 End Begin CommandButton quit_but Caption = "&Quit" Height = 495 Left = 8040 TabIndex = 14 Top = 5640 Width = 675 End Begin CommandButton prev_but Caption = "&Prev" Height = 495 Left = 1800 TabIndex = 13 Top = 5640 Width = 675 End Begin TextBox notes_box FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 2715 Left = 120 MultiLine = -1 'True ScrollBars = 2 'Vertical TabIndex = 10 Text = "Text1" Top = 1080 Width = 3015 End Begin TextBox adr5_box FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 420 Left = 4740 TabIndex = 7 Text = "Text1" Top = 3780 Width = 3975 End Begin TextBox adr4_box FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 420 Left = 4740 TabIndex = 6 Text = "Text1" Top = 3300 Width = 3975 End Begin TextBox fax_box FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 420 Left = 4740 TabIndex = 9 Text = "Text1" Top = 4740 Width = 4035 End Begin TextBox tel_box FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 420 Left = 4740 TabIndex = 8 Text = "Text5" Top = 4260 Width = 4035 End Begin TextBox adr3_box FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 420 Left = 4740 TabIndex = 5 Text = "Text4" Top = 2820 Width = 3975 End Begin TextBox adr2_box FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 420 Left = 4740 TabIndex = 4 Text = "Text3" Top = 2340 Width = 3975 End Begin TextBox adr1_box FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 420 Left = 4740 TabIndex = 3 Text = "Text2" Top = 1860 Width = 3975 End Begin TextBox surname_box FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 420 Left = 4740 TabIndex = 2 Text = "Text1" Top = 1380 Width = 3975 End Begin CommandButton find_but Caption = "&Find" Height = 495 Left = 3360 TabIndex = 12 Top = 5640 Width = 675 End Begin CommandButton next_but Caption = "&Next" Height = 495 Left = 1020 TabIndex = 11 Top = 5640 Width = 675 End Begin TextBox forename_box FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 420 Left = 4740 TabIndex = 1 Text = "Text1" Top = 900 Width = 3975 End Begin Label Label9 Caption = "Address:" FontBold = -1 'True FontItalic = -1 'True FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 3300 TabIndex = 31 Top = 1920 Width = 1335 End Begin Label Label8 Caption = "Forename:" FontBold = -1 'True FontItalic = -1 'True FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 3300 TabIndex = 30 Top = 960 Width = 1275 End Begin Label Label7 Caption = "Surname:" FontBold = -1 'True FontItalic = -1 'True FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 3300 TabIndex = 29 Top = 1440 Width = 1335 End Begin Label Label6 Caption = "Sort by:" FontBold = -1 'True FontItalic = -1 'True FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 120 TabIndex = 25 Top = 3960 Width = 1275 End Begin Label Label5 Caption = "Postcode:" FontBold = -1 'True FontItalic = -1 'True FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 3300 TabIndex = 22 Top = 3780 Width = 1395 End Begin Label Label4 Caption = "Notes:" FontBold = -1 'True FontItalic = -1 'True FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 120 TabIndex = 17 Top = 720 Width = 1215 End Begin Label Label3 Caption = "Fax:" FontBold = -1 'True FontItalic = -1 'True FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Left = 3300 TabIndex = 16 Top = 4800 Width = 1335 End Begin Label Label2 Caption = "Telephone:" FontBold = -1 'True FontItalic = -1 'True FontName = "Arial" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Left = 3300 TabIndex = 15 Top = 4320 Width = 1335 End Begin Label Label1 Alignment = 2 'Center Caption = "Address Book" FontBold = -1 'True FontItalic = 0 'False FontName = "Arial" FontSize = 24 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 495 Left = 0 TabIndex = 0 Top = 120 Width = 8895 End Sub action_check_click () Rem this sets filter to only addresses Rem with action outstanding Rem check for changed details before moving Rem to another record ' If you set a check box value in code, it triggers the click ' event. This is a good way to get infinite loops, and I don't ' like this effect! Therefore I've set a flag so that ' I can ignore unwanted click events. If ignore_click = 1 Then ignore_click = 0 Exit Sub End If curr_rec = adr_ds!recnum If chk_change() = "Cancel" Then ' reset check box without triggering code ignore_click = 1 If action_check.Value = 1 Then action_check.Value = 0 action_check.Value = 1 End If Exit Sub End If If action_check.Value Then Rem set filter filt_adr If Not action_check.Value Then ' it was changed back by filt_adr because no records exist ' with the action field true ' so restore current record criteria = "recnum = " + Str(curr_rec) adr_ds.FindFirst criteria End If refresh_sql criteria = "recnum = " + Str(curr_rec) adr_ds.FindFirst criteria End If upd_fields End Sub Sub Action_needed_Click () If newflag Then ' if a new record is current, we cannot ' update the dynaset yet Exit Sub End If adr_ds.Edit If action_needed.Value Then adr_ds("ACTION") = True Else adr_ds("ACTION") = False End If adr_ds.Update If action_check.Value = 1 Then Rem if we are presenting only records which have the action flag set, Rem then we need to update the SQL filt_adr End If upd_fields End Sub Sub del_but_Click () Dim decis As Integer decis = MsgBox("Really delete record?", 4) If decis = 6 Then adr_ds.Delete adr_ds.MovePrevious If adr_ds.BOF Then adr_ds.MoveFirst End If upd_fields End If End Sub Sub edit_but_Click () adr_ds.Edit End Sub Sub find_but_Click () If chk_change() = "Cancel" Then Exit Sub End If Dim rec_to_find As String, curr_rec As String, quotetest As Integer curr_rec = adr_ds.Bookmark If curr_ind = "address5" Then rec_to_find = InputBox$("Enter a post code", "Find a record") criteria = "ucase$(address5) >= " + "'" + UCase$(rec_to_find) + "'" rec_to_find = InputBox$("Enter a surname", "Find a record") criteria = "ucase$(Surname) >= " + "'" + UCase$(rec_to_find) + "'" End If ' test for empty string If rec_to_find = "" Then Exit Sub End If ' If user typed in a single quote, this causes a crash! ' Therefore, check first quotetest = InStr(rec_to_find, "'") If quotetest Then MsgBox ("Can't search for value including single quote") Exit Sub End If adr_ds.FindFirst criteria If adr_ds.NoMatch Then MsgBox ("Not found") adr_ds.Bookmark = curr_rec End If upd_fields End Sub Sub first_but_Click () If chk_change() = "Cancel" Then Exit Sub End If adr_ds.MoveFirst upd_fields End Sub Sub last_but_Click () If chk_change() = "Cancel" Then Exit Sub End If adr_ds.MoveLast upd_fields End Sub Sub list_but_Click () curr_rec = adr_ds!recnum If chk_change() = "Cancel" Then Exit Sub End If If first_list = 1 Then first_list = 0 Rem refresh list if first time 'It would be nice to refresh list automatically each 'time, but it takes sooooo long it seems better not 'to do it... upd_list End If list_form.Show End Sub Sub new_but_Click () adr_ds.AddNew newflag = -1 Dim countsnap As snapshot Dim newnum As Long ' Now find unique number for recnum field sql_stmnt = "Select max ([recnum]) as maxrec from address" Set countsnap = adr_db.CreateSnapshot(sql_stmnt) countsnap.MoveFirst newnum = countsnap!maxrec newnum = newnum + 1 ' assign new number to recnum adr_ds!recnum = newnum upd_fields End Sub Sub next_but_Click () If chk_change() = "Cancel" Then Exit Sub End If adr_ds.MoveNext If Not adr_ds.EOF Then upd_fields MsgBox ("No more addresses") adr_ds.MoveLast upd_fields End If End Sub Sub notes_box_LostFocus () If newflag Then ' can't update dynaset if new record Exit Sub End If adr_ds.Edit adr_ds("NOTES") = notes_box.Text adr_ds.Update End Sub Sub order_option_Click (Index As Integer) Dim decis As Integer curr_rec = adr_ds!recnum If chk_change() = "Cancel" Then Exit Sub End If Select Case Index Case 0 curr_ind = "address5" ' address5 is the name of the postcode field Case 1 curr_ind = "surname" End Select refresh_sql criteria = "recnum = " + Str(curr_rec) adr_ds.FindFirst criteria upd_fields End Sub Sub pack_but_Click () If chk_change() = "Cancel" Then Exit Sub End If screen.MousePointer = 11 Dim adr_tb As table Dim oldtd As tabledef Dim newtb As table Dim newtd As New tabledef Dim newix As New Index Dim fieldcount As Integer curr_rec = adr_ds!recnum Rem close the dynaset adr_ds.Close Set adr_tb = adr_db.OpenTable("ADDRESS") Rem open the address table Set oldtd = adr_db.TableDefs("ADDRESS") Rem define fields fieldcount = oldtd.Fields.Count - 1 ReDim newfields(fieldcount) As New field Dim countvar As Integer For countvar = 0 To fieldcount newfields(countvar).Name = oldtd.Fields(countvar).Name newfields(countvar).Type = oldtd.Fields(countvar).Type newfields(countvar).Size = oldtd.Fields(countvar).Size Rem now build new tabledef newtd.Name = "NEWTABLE" Rem add fields For countvar = 0 To fieldcount newtd.Fields.Append newfields(countvar) Rem append new table to database adr_db.TableDefs.Append newtd Rem open new table Set newtb = adr_db.OpenTable("NEWTABLE") Rem copy records from old to new Rem set order to adr_tb.Index = "" adr_tb.MoveFirst sql_stmnt = "insert into newtable select * from address" adr_db.Execute sql_stmnt Rem now duplicate indexes indexcount = oldtd.Indexes.Count - 1 ReDim newindexes(indexcount) As New Index For countvar = 0 To indexcount newindexes(countvar).Fields = oldtd.Indexes(countvar).Fields newindexes(countvar).Name = oldtd.Indexes(countvar).Name newindexes(countvar).Unique = oldtd.Indexes(countvar).Unique newindexes(countvar).Primary = oldtd.Indexes(countvar).Primary Rem add indexes newtb.Close Rem must close table before indexing For countvar = 0 To indexcount newtd.Indexes.Append newindexes(countvar) Rem delete and rename adr_tb.Close adr_db.Close Kill "C:\ADR\ADDRESS.DBF" Kill "C:\ADR\ADDRESS.FPT" Kill "C:\ADR\ADDRESS.CDX" Name "C:\ADR\NEWTABLE.DBF" As "C:\ADR\ADDRESS.DBF" Name "C:\ADR\NEWTABLE.FPT" As "C:\ADR\ADDRESS.FPT" Name "C:\ADR\NEWTABLE.CDX" As "C:\ADR\ADDRESS.CDX" Rem reopen database and table Set adr_db = OpenDatabase("C:\ADR", False, False, "FoxPro 2.5;") ' Restore dynaset refresh_sql ' restore current record criteria = "recnum = " + Str(curr_rec) adr_ds.FindFirst criteria upd_fields screen.MousePointer = 0 MsgBox ("Pack completed") End Sub Sub prev_but_Click () If chk_change() = "Cancel" Then Exit Sub End If adr_ds.MovePrevious If Not adr_ds.BOF Then upd_fields MsgBox ("No previous addresses") adr_ds.MoveFirst upd_fields End If End Sub Sub quit_but_Click () If chk_change() = "Cancel" Then Exit Sub End If End Sub Sub save_but_Click () save_rec End Sub