Liren Large Software Subsidy 10

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

/ Liren Large Software Subsidy 10 / 10.iso / l / l407 / 5.ddi / TABLEOBJ.FR_ / TABLEOBJ.bin

(.txt)

Wrap

Visual Basic Form | 1993-04-28 | 25.5 KB | 864 lines

VERSION 2.00 Begin Form fTableObj BackColor = &H00C0C0C0& ClientHeight = 3495 ClientLeft = 1335 ClientTop = 2625 ClientWidth = 5655 Height = 3900 Icon = TABLEOBJ.FRX:0000 KeyPreview = -1 'True Left = 1275 LinkTopic = "Form1" MDIChild = -1 'True ScaleHeight = 3480 ScaleMode = 0 'User ScaleWidth = 5675.317 Tag = "Dynaset" Top = 2280 Width = 5775 Begin PictureBox FieldHeader BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 240 Left = 0 ScaleHeight = 240 ScaleMode = 0 'User ScaleWidth = 5028 TabIndex = 22 Top = 720 Width = 5025 Begin Label FieldValueLabel BackColor = &H00C0C0C0& Caption = " Value (F4=Zoom) " Height = 255 Left = 1680 TabIndex = 24 Top = 0 Width = 3165 End Begin Label FieldHdrLabel BackColor = &H00C0C0C0& Caption = "Field Name:" Height = 252 Left = 120 TabIndex = 23 Top = 0 Width = 1212 End End Begin PictureBox ViewButtons Align = 1 'Align Top BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 735 Left = 0 ScaleHeight = 735 ScaleMode = 0 'User ScaleWidth = 5658.376 TabIndex = 1 TabStop = 0 'False Top = 0 Width = 5655 Begin ComboBox cIndexes BackColor = &H00FFFFFF& Height = 300 Left = 720 Style = 2 'Dropdown List TabIndex = 9 Tag = "OL" Top = 360 Width = 4335 End Begin CommandButton SeekButton Caption = "&Seek" Height = 330 Left = 2160 TabIndex = 5 Top = 0 Width = 750 End Begin CommandButton FilterButton Caption = "F&ilter" Height = 330 Left = 2880 TabIndex = 6 Top = 0 Width = 750 End Begin CommandButton CloseButton Cancel = -1 'True Caption = "&Close" Height = 330 Left = 4305 TabIndex = 8 TabStop = 0 'False Top = 0 Width = 750 End Begin CommandButton PropButton Caption = "&Prop" Height = 330 Left = 3600 TabIndex = 7 Top = 0 Width = 750 End Begin CommandButton DelButton Caption = "&Del" Height = 330 Left = 1440 TabIndex = 4 Top = 0 Width = 750 End Begin CommandButton EditButton Caption = "&Edit" Height = 330 Left = 720 TabIndex = 3 Top = 0 Width = 750 End Begin CommandButton AddButton Caption = "&Add" Height = 330 Left = 0 TabIndex = 2 Top = 0 Width = 750 End Begin Label IndexLabel BackColor = &H00C0C0C0& Caption = "Index:" Height = 255 Left = 120 TabIndex = 25 Top = 400 Width = 615 End End Begin PictureBox ChangeButtons BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 690 Left = 0 ScaleHeight = 690 ScaleMode = 0 'User ScaleWidth = 5658.376 TabIndex = 14 TabStop = 0 'False Top = 0 Visible = 0 'False Width = 5655 Begin CommandButton UpdateButton Caption = "&Update" Height = 372 Left = 960 TabIndex = 16 Top = 48 Width = 1212 End Begin CommandButton CancelButton Caption = "&Cancel" Height = 372 Left = 2640 TabIndex = 15 Top = 48 Width = 1212 End End Begin PictureBox StatBox Align = 2 'Align Bottom BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 281 Left = 0 ScaleHeight = 298.153 ScaleMode = 0 'User ScaleWidth = 5665.189 TabIndex = 20 TabStop = 0 'False Top = 3210 Width = 5655 Begin CommandButton NextButton Caption = ">" FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 287 Left = 4200 TabIndex = 12 Top = 0 Width = 375 End Begin CommandButton LastButton Caption = ">|" FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 287 Left = 4575 TabIndex = 13 Top = 0 Width = 375 End Begin CommandButton FirstButton Caption = "|<" FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 287 Left = 0 TabIndex = 10 Top = 0 Width = 375 End Begin CommandButton PrevButton Caption = "<" FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 12 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 287 Left = 375 TabIndex = 11 Top = 0 Width = 375 End Begin Label cStatusBar BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Height = 285 Left = 735 TabIndex = 21 Top = 0 Width = 3360 End End Begin VScrollBar cScrollBar Height = 2616 LargeChange = 3000 Left = 5040 SmallChange = 300 TabIndex = 19 Top = 960 Visible = 0 'False Width = 252 End Begin PictureBox cFields BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 375 Left = 120 ScaleHeight = 372 ScaleMode = 0 'User ScaleWidth = 4812 TabIndex = 17 TabStop = 0 'False Top = 960 Width = 4815 Begin TextBox cFieldData BackColor = &H00FFFFFF& DataSource = "Data1" ForeColor = &H00000000& Height = 288 Index = 0 Left = 1560 TabIndex = 0 Top = 0 Visible = 0 'False Width = 3252 End Begin Label cFieldName BackColor = &H00C0C0C0& ForeColor = &H00000000& Height = 252 Index = 0 Left = 0 TabIndex = 18 Top = 60 Visible = 0 'False Width = 1572 End End Option Explicit 'form variables Dim FTBL As Table 'current form's table Dim FTblName As String 'form dynaset table name Dim FBM As String 'form bookmark Dim FNotFound As Integer 'used by find function Dim FAtTop As Integer 'top flag Dim FEditFlag As Integer 'edit mode Dim FAddNewFlag As Integer 'add mode Dim FFldDataChanged As Integer Dim FSeekForm As New fSeek 'seek form instance Dim FCurrRec As Integer 'record counter Dim FNumbRows As Long 'total rows in Table Sub AddButton_Click () On Error GoTo AddErr 'set the mode FTBL.AddNew cStatusBar = "Add record" FAddNewFlag = True If FTBL.RecordCount > 0 Then FBM = FTBL.Bookmark Else FBM = "" End If ChangeButtons.Visible = True ViewButtons.Visible = False NextButton.Enabled = False FirstButton.Enabled = False LastButton.Enabled = False PrevButton.Enabled = False ClearDataFields cFieldData(0).SetFocus GoTo AddEnd AddErr: ShowError Resume AddEnd AddEnd: End Sub Sub CancelButton_Click () On Error Resume Next ChangeButtons.Visible = False ViewButtons.Visible = True NextButton.Enabled = True FirstButton.Enabled = True LastButton.Enabled = True PrevButton.Enabled = True FEditFlag = False FAddNewFlag = False If FBM <> "" Then FTBL.Bookmark = FBM DisplayCurrentRecord End Sub Sub cFieldData_Change (Index As Integer) 'just set the flag if data is changed 'it gets reset to false when a new record is displayed FFldDataChanged = True End Sub Sub cFieldData_KeyDown (Index As Integer, KeyCode As Integer, Shift As Integer) If KeyCode = &H73 Then 'F4 cFieldName_DblClick Index ElseIf KeyCode = 34 And cScrollBar.Visible = True Then 'pagedown with > 10 fields cScrollBar = cScrollBar - 3000 ElseIf KeyCode = 33 And cScrollBar.Visible = True Then 'pageup with > 10 fields cScrollBar = cScrollBar + 3000 End If End Sub Sub cFieldData_KeyPress (Index As Integer, KeyAscii As Integer) 'only allow return when in edit of add mode If FEditFlag = True Or FAddNewFlag = True Then If FTBL(Index).Type = FT_STRING And Len(cFieldData(Index)) > FTBL(Index).Size Then Beep MsgBox "Field Length Exceeded!", 48 KeyAscii = 0 Exit Sub End If If KeyAscii = 13 Then KeyAscii = 0 SendKeys "{Tab}" End If 'throw away the keystrokes if not in add or edit mode ElseIf FEditFlag = False And FAddNewFlag = False Then KeyAscii = 0 End If End Sub Sub cFieldData_LostFocus (Index As Integer) On Error GoTo FldDataErr If FFldDataChanged = True Then 'store the data in the field FTBL(Index) = cFieldData(Index) End If GoTo FldDataEnd FldDataErr: ShowError Resume FldDataEnd FldDataEnd: 'reset for valid or error condition FFldDataChanged = False End Sub Sub cFieldName_DblClick (Index As Integer) On Error GoTo ZoomErr If FTBL(Index).Type = FT_STRING Or FTBL(Index).Type = FT_MEMO Then If FTBL(Index).FieldSize() < GETCHUNK_CUTOFF Then gstZoomData = cFieldData(Index) Else 'add the rest of the field data with getchunk MsgBar "Getting Memo Field Data", True SetHourglass Me gstZoomData = cFieldData(Index) + StripNonAscii(FTBL(Index).GetChunk(GETCHUNK_CUTOFF, MAX_MEMO_SIZE)) ResetMouse Me MsgBar "", False End If fZoom.Caption = Mid(cFieldName(Index), 1, Len(cFieldName(Index)) - 1) fZoom.Top = Top + 1200 fZoom.Left = Left + 250 If FAddNewFlag Or FEditFlag Then fZoom.SaveButton.Visible = True fZoom.CloseButton.Visible = True Else fZoom.CloseZoomButton.Visible = True End If fZoom.Show MODAL If FAddNewFlag Or FEditFlag Then If FTBL(Index).Type = FT_STRING And Len(gstZoomData) > FTBL(Index).Size Then Beep MsgBox "Field Length Exceeded, Data Truncated!", 48 cFieldData(Index) = Mid(gstZoomData, 1, FTBL(Index).Size) Else cFieldData(Index) = gstZoomData End If FTBL(Index) = cFieldData(Index) FFldDataChanged = False End If End If GoTo ZoomEnd ZoomErr: ShowError Resume ZoomEnd ZoomEnd: End Sub Sub cIndexes_Click () On Error GoTo IndErr If FTBL Is Nothing Then Exit Sub If FTBL.Index = Mid(cIndexes, 1, InStr(1, cIndexes, ":") - 1) Then Exit Sub FTBL.Index = Mid(cIndexes, 1, InStr(1, cIndexes, ":") - 1) FCurrRec = 1 DisplayCurrentRecord FAtTop = True GoTo IndEnd IndErr: ShowError Resume IndEnd IndEnd: End Sub Sub ClearDataFields () Dim i As Integer 'clear out the fields on the main form For i = 0 To FTBL.Fields.Count - 1 cFieldData(i) = "" Next End Sub Sub CloseButton_Click () Unload Me End Sub Sub cScrollBar_Change () Dim t As Integer t = cScrollBar If (t - 960) Mod 300 = 0 Then cFields.Top = t Else cFields.Top = ((t - 960) \ 300) * 300 + 960 End If End Sub Sub DelButton_Click () On Error GoTo DelRecErr If MsgBox("Delete Current Record?", MSGBOX_TYPE) = YES Then FTBL.Delete If gfTransPending Then gfDBChanged = True If FTBL.EOF = False Then FTBL.MoveNext End If FNumbRows = FNumbRows - 1 DisplayCurrentRecord End If GoTo DelRecEnd DelRecErr: ShowError Resume DelRecEnd DelRecEnd: End Sub Sub DisplayCurrentRecord () Dim i As Integer Dim cst As String 'current status bar Dim currstr As String On Error GoTo DCRErr SetHourglass Me If FCurrRec = -1 And FTBL.RecordCount = 0 Then currstr = "?" Else currstr = CStr(FCurrRec) End If cst = "Record " 'check BOF/EOF flag so we know if we 'are sitting on a valid record If FAddNewFlag = True Then cst = cst + currstr + " of " + CStr(FNumbRows) Else If FTBL.BOF = True Then FCurrRec = 0 cst = cst + "(BOF) of " + CStr(FNumbRows) ClearDataFields ElseIf FTBL.EOF = True Then FCurrRec = FNumbRows + 1 cst = cst + "(EOF) of " + CStr(FNumbRows) ClearDataFields Else cst = cst + currstr + " of " + CStr(FNumbRows) 'place the data in the form fields For i = 0 To FTBL.Fields.Count - 1 If FTBL(i).Type = FT_MEMO Then If FTBL(i).FieldSize() < GETCHUNK_CUTOFF Then cFieldData(i) = StripNonAscii(vFieldVal(FTBL(i))) Else cFieldData(i) = StripNonAscii(vFieldVal(FTBL(i).GetChunk(0, GETCHUNK_CUTOFF))) End If ElseIf FTBL(i).Type = FT_STRING Then cFieldData(i) = StripNonAscii(vFieldVal(FTBL(i))) Else cFieldData(i) = vFieldVal(FTBL(i)) End If Next End If End If If gfUpdatable = False Then cst = cst + " [Not Updatable]" cStatusBar = cst 'set the flag FFldDataChanged = False GoTo DCREnd DCRErr: ShowError Resume DCREnd DCREnd: ResetMouse Me End Sub Sub EditButton_Click () On Error GoTo EditErr FTBL.Edit cStatusBar = "Edit record" FEditFlag = True cFieldData(0).SetFocus FBM = FTBL.Bookmark ChangeButtons.Visible = True ViewButtons.Visible = False NextButton.Enabled = False FirstButton.Enabled = False LastButton.Enabled = False PrevButton.Enabled = False GoTo EditEnd EditErr: ShowError Resume EditEnd EditEnd: End Sub Sub FilterButton_Click () On Error GoTo FilterErr Dim FilterStr As String Dim f As New fDynaset FilterStr = InputBox("Enter Filter Expression:") If FilterStr = "" Then Exit Sub gstTableDynaFilter = "select * from " + FTblName + " where " + FilterStr f.Show 'open dynaset form w/ filtered table gstTableDynaFilter = "" GoTo FilterEnd FilterErr: ShowError Resume FilterEnd FilterEnd: End Sub Sub FirstButton_Click () Dim ds As String On Error GoTo GoFirstError FTBL.MoveFirst FCurrRec = 1 DisplayCurrentRecord FAtTop = True GoTo GoFirstEnd GoFirstError: ShowError Resume GoFirstEnd GoFirstEnd: ResetMouse Me MsgBar "", False End Sub Sub Form_KeyDown (KeyCode As Integer, Shift As Integer) If FEditFlag = True Or FAddNewFlag = True Then Exit Sub Select Case KeyCode Case 35 'end Call LastButton_Click Case 36 'home Call FirstButton_Click Case 38 'up arrow If Shift = 2 Then Call FirstButton_Click Else Call PrevButton_Click End If Case 40 'down arrow If Shift = 2 Then Call LastButton_Click Else Call NextButton_Click End If End Select End Sub Sub Form_Load () Dim ft As Integer Dim i As Integer Dim tbl As tabledef Dim istr As String On Error GoTo TableErr SetHourglass Me MsgBar "Opening Table", True FTblName = fTables.cTableList Set tbl = gCurrentDB.TableDefs(FTblName) For i = 0 To tbl.Indexes.Count - 1 istr = tbl.Indexes(i).Name istr = istr + ":" + tbl.Indexes(i).Fields If tbl.Indexes(i).Unique = True Then istr = istr + ":Unique" Else istr = istr + ":Non-Unique" End If If tbl.Indexes(i).Primary = True Then istr = istr + ":Primary" End If cIndexes.AddItem istr Next Set FTBL = gCurrentDB.OpenTable(FTblName) 'show the first record FNumbRows = GetNumbRecsTbl(FTBL) 'query numb of recs 'load the controls on the Table form cFieldName(0).Visible = True cFieldData(0).Visible = True ft = FTBL(0).Type cFieldData(0).Width = GetFieldWidth(ft) cFieldData(0).TabIndex = 0 For i = 1 To FTBL.Fields.Count - 1 cFields.Height = cFields.Height + 300 Load cFieldName(i) cFieldName(i).Top = cFieldName(i - 1).Top + 300 cFieldName(i).Visible = True Load cFieldData(i) cFieldData(i).Top = cFieldData(i - 1).Top + 300 cFieldData(i).Visible = True ft = FTBL.Fields(i).Type cFieldData(i).Width = GetFieldWidth(ft) cFieldData(i).TabIndex = i Next 'resize main window If i <= 10 Then Height = ((i + 1) * 300) + 1600 Else Height = 4668 Width = Width + 260 cScrollBar.Visible = True cScrollBar.Min = 900 cScrollBar.Max = 900 - (i * 300) + 3000 End If 'display the field names For i = 0 To FTBL.Fields.Count - 1 cFieldName(i) = UCase(FTBL(i).Name) + ":" Next FCurrRec = 1 If cIndexes.ListCount > 0 Then cIndexes.ListIndex = 0 End If DisplayCurrentRecord 'display field values FAtTop = True Caption = "Table: " + FTblName Width = 5805 Left = 1000 Top = 1000 GoTo OkayEnd TableErr: ShowError ResetMouse Me Unload Me MsgBar "", False Exit Sub Resume OkayEnd OkayEnd: ResetMouse Me MsgBar "", False End Sub Sub Form_Paint () Outlines Me End Sub Sub Form_Resize () On Error Resume Next Dim h As Integer, i As Integer Dim totw As Integer If WindowState <> 1 Then 'not minimized MsgBar "Resizing Form", True 'make sure the form is lined up on a field h = Height If (h - 1660) Mod 300 <> 0 Then Height = ((h - 1660) \ 300) * 300 + 1660 End If 'resize the status bar StatBox.Top = Height - 650 'resize the scrollbar cScrollBar.Height = StatBox.Top - (ViewButtons.Top - FieldHeader.Height) - 1200 cScrollBar.Left = Width - 360 If FTBL.Fields.Count > 10 Then cFields.Width = Width - 260 totw = cScrollBar.Left - 20 Else cFields.Width = Width - 20 totw = Width - 50 End If FieldHeader.Width = Width - 20 'widen the fields if possible For i = 0 To FTBL.Fields.Count - 1 cFieldName(i).Width = .3 * totw cFieldData(i).Left = cFieldName(i).Width + 20 If FTBL(i).Type = FT_STRING Or FTBL(i).Type = FT_MEMO Then cFieldData(i).Width = .7 * totw - 250 End If Next FieldValueLabel.Left = cFieldData(0).Left cStatusBar.Width = Width - 1600 NextButton.Left = cStatusBar.Width + 745 LastButton.Left = NextButton.Left + 370 End If MsgBar "", False End Sub Sub Form_Unload (Cancel As Integer) On Error Resume Next Unload FSeekForm 'get rid of attached seek form FTBL.Close 'close the form Table MsgBar "", False End Sub Sub LastButton_Click () On Error GoTo GoLastError FTBL.MoveLast 'show the current record FCurrRec = FNumbRows DisplayCurrentRecord GoTo GoLastEnd GoLastError: ShowError Resume GoLastEnd GoLastEnd: End Sub Sub NextButton_Click () On Error GoTo GoNextError FTBL.MoveNext 'show the current record If FCurrRec <> -1 Then FCurrRec = FCurrRec + 1 'bump the record counter End If DisplayCurrentRecord FAtTop = False GoTo GoNextEnd GoNextError: ShowError Resume GoNextEnd GoNextEnd: End Sub Sub PrevButton_Click () On Error GoTo GoPrevError FTBL.MovePrevious 'show the current record If FCurrRec <> -1 Then FCurrRec = FCurrRec - 1 'bump the record counter back End If DisplayCurrentRecord FAtTop = False GoTo GoPrevEnd GoPrevError: ShowError Resume GoPrevEnd GoPrevEnd: End Sub Sub PropButton_Click () Dim f As New fDataBox On Error GoTo DynPropErr Set gCurrentTbl = FTBL f.Caption = "Table Properties" f.Tag = "TBL" f.cData.AddItem "Name = " + FTBL.Name f.cData.AddItem "BOF Flag = " + stTrueFalse((FTBL.BOF)) f.cData.AddItem "BookMark = " + FTBL.Bookmark f.cData.AddItem "BookMarkable Flag = " + stTrueFalse((FTBL.Bookmarkable)) f.cData.AddItem "Date Created = " + FTBL.DateCreated f.cData.AddItem "EOF Flag = " + stTrueFalse((FTBL.EOF)) f.cData.AddItem "Index = " + FTBL.Index f.cData.AddItem "Last Modified = " + FTBL.LastModified f.cData.AddItem "Last Updated = " + FTBL.LastUpdated f.cData.AddItem "Lock Edits Flag = " + stTrueFalse((FTBL.LockEdits)) f.cData.AddItem "No Match Flag = " + stTrueFalse((FTBL.NoMatch)) f.cData.AddItem "Transactions Flag = " + stTrueFalse((FTBL.Transactions)) f.cData.AddItem "RecordCount = " & FTBL.RecordCount f.cData.AddItem "Updatable Flag = " + stTrueFalse((FTBL.Updatable)) f.Show MODAL GoTo DynPropEnd DynPropErr: f.cData.AddItem Error$ Resume Next DynPropEnd: End Sub Sub SeekButton_Click () On Error GoTo SeekErr Dim bm As String If FTBL.RecordCount = 0 Then Exit Sub SeekStart: MsgBar "Enter Seek Parameters", False fSeek.Show MODAL If gstSeekValue = "" Then GoTo SeekEnd bm = FTBL.Bookmark SetHourglass Me FTBL.Seek gstSeekOperator, gstSeekValue ResetMouse Me 'return to old record if no match was found If FTBL.NoMatch And bm <> "" Then Beep MsgBox "Record Not Found", 48 FTBL.Bookmark = bm GoTo SeekStart Else If FCurrRec <> -1 Then MsgBox "Current Record Number cannot be retained after Seek!" End If FCurrRec = -1 'set to -1 because it is no longer valid End If DisplayCurrentRecord GoTo SeekEnd SeekErr: ResetMouse Me MsgBox Error$ Resume SeekEnd SeekEnd: MsgBar "", False End Sub Sub UpdateButton_Click () On Error GoTo UpdateErr FTBL.Update If gfTransPending Then gfDBChanged = True If FAddNewFlag = True Then FNumbRows = FNumbRows + 1 FCurrRec = FNumbRows FTBL.MoveLast 'move to the new record End If FEditFlag = False FAddNewFlag = False ChangeButtons.Visible = False ViewButtons.Visible = True NextButton.Enabled = True FirstButton.Enabled = True LastButton.Enabled = True PrevButton.Enabled = True DisplayCurrentRecord GoTo UpdateEnd UpdateErr: ShowError Resume UpdateEnd UpdateEnd: End Sub