Liren Large Software Subsidy 10

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

/ Liren Large Software Subsidy 10 / 10.iso / l / l406 / 4.ddi / DYNASET.FR_ / DYNASET.bin

(.txt)

Wrap

Visual Basic Form | 1992-10-21 | 23.9 KB | 817 lines

VERSION 2.00 Begin Form fDynaset BackColor = &H00C0C0C0& Height = 3900 Icon = DYNASET.FRX:0000 Left = 3615 LinkTopic = "Form1" MDIChild = -1 'True ScaleHeight = 3480 ScaleMode = 0 'User ScaleWidth = 5028 Tag = "Dynaset" Top = 2490 Width = 5130 Begin PictureBox FieldHeader BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 241 Left = 0 ScaleHeight = 240 ScaleMode = 0 'User ScaleWidth = 5028 TabIndex = 18 Top = 482 Width = 5007 Begin Label FieldValueLabel BackColor = &H00C0C0C0& Caption = " Value (F4=Zoom)" Height = 252 Left = 1674 TabIndex = 20 Top = 0 Width = 2643 End Begin Label FieldHdrLabel BackColor = &H00C0C0C0& Caption = "Field Name:" Height = 252 Left = 120 TabIndex = 19 Top = 0 Width = 1208 End End Begin PictureBox ViewButtons Align = 1 'Align Top BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 480 Left = 0 ScaleHeight = 480 ScaleMode = 0 'User ScaleWidth = 5012.991 TabIndex = 0 Top = 0 Width = 5010 Begin CommandButton CloseButton Caption = "&Close" Height = 372 Left = 4320 TabIndex = 11 TabStop = 0 'False Top = 50 Width = 612 End Begin CommandButton PropButton Caption = "&Prop" Height = 372 Left = 3720 TabIndex = 7 Top = 50 Width = 612 End Begin CommandButton DelButton Caption = "&Del" Height = 372 Left = 3120 TabIndex = 6 Top = 50 Width = 612 End Begin CommandButton EditButton Caption = "&Edit" Height = 372 Left = 2520 TabIndex = 5 Top = 50 Width = 612 End Begin CommandButton AddButton Caption = "&Add" Height = 372 Left = 1920 TabIndex = 4 Top = 50 Width = 612 End Begin CommandButton FindButton Caption = "F&ind" Height = 372 Left = 1320 TabIndex = 3 Top = 50 Width = 612 End Begin CommandButton FirstButton Caption = "&First" Height = 372 Left = 720 TabIndex = 2 Top = 50 Width = 612 End Begin CommandButton NextButton Caption = "&Next" Height = 372 Left = 120 TabIndex = 1 Top = 50 Width = 612 End End Begin PictureBox ChangeButtons BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 480 Left = 0 ScaleHeight = 480 ScaleMode = 0 'User ScaleWidth = 5028 TabIndex = 8 Top = 0 Visible = 0 'False Width = 5028 Begin CommandButton UpdateButton Caption = "&Update" Height = 372 Left = 960 TabIndex = 10 Top = 48 Width = 1212 End Begin CommandButton CancelButton Cancel = -1 'True Caption = "&Cancel" Height = 372 Left = 2640 TabIndex = 9 Top = 48 Width = 1212 End End Begin PictureBox StatBox Align = 2 'Align Bottom BackColor = &H00FFFFFF& Height = 225 Left = 0 ScaleHeight = 204 ScaleMode = 0 'User ScaleWidth = 6292.909 TabIndex = 16 Top = 3270 Width = 5010 Begin Label cStatusBar BackColor = &H00FFFFFF& Height = 252 Left = 95 TabIndex = 17 Top = 0 Width = 3827 End End Begin VScrollBar cScrollBar Height = 2627 LargeChange = 3000 Left = 5022 SmallChange = 300 TabIndex = 15 Top = 723 Visible = 0 'False Width = 251 End Begin PictureBox cFields BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 377 Left = 120 ScaleHeight = 372 ScaleMode = 0 'User ScaleWidth = 4812 TabIndex = 12 Top = 723 Width = 4798 Begin TextBox cFieldData BackColor = &H00FFFFFF& Height = 290 Index = 0 Left = 1556 TabIndex = 13 Top = 0 Visible = 0 'False Width = 3244 End Begin Label cFieldName BackColor = &H00C0C0C0& ForeColor = &H00000000& Height = 254 Index = 0 Left = 0 TabIndex = 14 Top = 60 Visible = 0 'False Width = 1568 End End Option Explicit 'form variables Dim FDS As Dynaset 'current form's dynaset Dim FTblName As String 'form dynaset table name 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 FFindForm As New fFind 'find form instance Dim FCurrRec As Integer 'record counter Dim FNumbRows As Long 'total rows in dynaset Dim FDynaString As String 'dynaset open string Sub AddButton_Click () On Error GoTo AddErr 'move to the end so you'll be on the 'record after the add is complete ' While FDS.EOF = False ' FDS.MoveNext ' Wend 'set the mode FDS.AddNew cStatusBar = "Add record" FAddNewFlag = True ChangeButtons.Visible = True ViewButtons.Visible = 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 FDS.Edit 'get last read data from server DisplayCurrentRecord FEditFlag = False FAddNewFlag = False 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 FDS(Index).Type = FT_STRING And Len(cFieldData(Index)) > FDS(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 FDS(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 FDS(Index).Type = FT_STRING Or FDS(Index).Type = FT_MEMO Then If FDS(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(FDS(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 FDS(Index).Type = FT_STRING And Len(gstZoomData) > FDS(Index).Size Then Beep MsgBox "Field Length Exceeded, Data Truncated!", 48 cFieldData(Index) = Mid(gstZoomData, 1, FDS(Index).Size) Else cFieldData(Index) = gstZoomData End If FDS(Index) = cFieldData(Index) FFldDataChanged = False End If End If GoTo ZoomEnd ZoomErr: ShowError Resume ZoomEnd ZoomEnd: End Sub Sub ClearDataFields () Dim i As Integer 'clear out the fields on the main form For i = 0 To FDS.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 - 720) Mod 300 = 0 Then cFields.Top = t Else cFields.Top = ((t - 720) \ 300) * 300 + 720 End If End Sub Sub DelButton_Click () On Error GoTo DelRecErr If MsgBox("Delete Current Record?", MSGBOX_TYPE) = YES Then FDS.Delete If gfTransPending Then gfDBChanged = True If FDS.EOF = False Then FDS.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 On Error GoTo DCRErr SetHourGlass Me cst = "View Records " 'check EOF flag so we know if we 'are sitting on a valid record If FAddNewFlag = True Then cst = cst + CStr(FCurrRec) + "/" + CStr(FNumbRows) Else If FDS.EOF <> False Then '= True Then cst = cst + "(EOF)/" + CStr(FNumbRows) ClearDataFields Else cst = cst + CStr(FCurrRec) + "/" + CStr(FNumbRows) 'place the data in the form fields For i = 0 To FDS.Fields.Count - 1 If FDS(i).Type = FT_MEMO Then If FDS(i).FieldSize() < GETCHUNK_CUTOFF Then cFieldData(i) = StripNonAscii(vFieldVal(FDS(i))) Else cFieldData(i) = StripNonAscii(vFieldVal(FDS(i).GetChunk(0, GETCHUNK_CUTOFF))) End If ElseIf FDS(i).Type = FT_STRING Then cFieldData(i) = StripNonAscii(vFieldVal(FDS(i))) Else cFieldData(i) = vFieldVal(FDS(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 FDS.Edit cStatusBar = "Edit record" FEditFlag = True cFieldData(0).SetFocus ChangeButtons.Visible = True ViewButtons.Visible = False GoTo EditEnd EditErr: ShowError Resume EditEnd EditEnd: End Sub Sub FindButton_Click () Dim i As Integer If CheckTransPending("'Find' Not Available during a Transaction") = True Then Exit Sub On Error GoTo FindErr 'load the column names into the find form If FFindForm.cFieldList.ListCount = 0 Then For i = 0 To FDS.Fields.Count - 1 FFindForm.cFieldList.AddItem Mid(cFieldName(i), 1, Len(cFieldName(i)) - 1) Next End If FindStart: 'reset the flags gfFindFailed = False gfFromTableView = False FNotFound = False MsgBar "Enter Search Parameters", False FFindForm.Show MODAL MsgBar "Searching for New Record", True If gfFindFailed = True Then 'find cancelled GoTo AfterWhile End If SetHourGlass Me 'reopen the dynaset if not at the top If FAtTop = False Then FDS.Close Set FDS = gCurrentDB.CreateDynaset(FDS.Name) FCurrRec = 1 End If i = FFindForm.cFieldList.ListIndex 'search for the record While FDS.EOF = False If FDS(i).Type = FT_STRING Then If gfFindMatch = False Then Select Case gstFindOp Case "=" If UCase(FDS(i)) = UCase(gstFindExpr) Then GoTo AfterWhile Case "<>" If UCase(FDS(i)) <> UCase(gstFindExpr) Then GoTo AfterWhile Case ">=" If UCase(FDS(i)) >= UCase(gstFindExpr) Then GoTo AfterWhile Case "<=" If UCase(FDS(i)) <= UCase(gstFindExpr) Then GoTo AfterWhile Case ">" If UCase(FDS(i)) > UCase(gstFindExpr) Then GoTo AfterWhile Case "<" If UCase(FDS(i)) < UCase(gstFindExpr) Then GoTo AfterWhile Case "Like" If UCase(FDS(i)) Like UCase(gstFindExpr) Then GoTo AfterWhile End Select Else Select Case gstFindOp Case "=" If FDS(i) = gstFindExpr Then GoTo AfterWhile Case "<>" If FDS(i) <> gstFindExpr Then GoTo AfterWhile Case ">=" If FDS(i) >= gstFindExpr Then GoTo AfterWhile Case "<=" If FDS(i) <= gstFindExpr Then GoTo AfterWhile Case ">" If FDS(i) > gstFindExpr Then GoTo AfterWhile Case "<" If FDS(i) < gstFindExpr Then GoTo AfterWhile Case "Like" If FDS(i) Like gstFindExpr Then GoTo AfterWhile End Select End If Else Select Case gstFindOp Case "=" If FDS(i) = Val(gstFindExpr) Then GoTo AfterWhile Case "<>" If FDS(i) <> Val(gstFindExpr) Then GoTo AfterWhile Case ">=" If FDS(i) >= Val(gstFindExpr) Then GoTo AfterWhile Case "<=" If FDS(i) <= Val(gstFindExpr) Then GoTo AfterWhile Case ">" If FDS(i) > Val(gstFindExpr) Then GoTo AfterWhile Case "<" If FDS(i) < Val(gstFindExpr) Then GoTo AfterWhile End Select End If FDS.MoveNext FCurrRec = FCurrRec + 1 Wend FNotFound = True 'didn't find it AfterWhile: ResetMouse Me FAtTop = False If gfFindFailed = True Then 'go back to top FDS.Close Set FDS = gCurrentDB.CreateDynaset(FDS.Name) FAtTop = True FCurrRec = 1 ElseIf FNotFound Then Beep MsgBox "Record Not Found", 48 GoTo FindStart End If DisplayCurrentRecord GoTo FindEnd FindErr: ResetMouse Me If Err <> EOF_ERR Then ShowError Resume FindEnd Else FNotFound = True Resume Next End If FindEnd: MsgBar "", False End Sub Sub FirstButton_Click () On Error GoTo GoFirstError If CheckTransPending("'First' Not Available during a Transaction") = True Then Exit Sub MsgBar "Going to First Record", True SetHourGlass Me FDS.Close Set FDS = gCurrentDB.CreateDynaset(FDS.Name) FNumbRows = GetNumbRecs(FDS, FDynaString) 'show the first record FCurrRec = 1 DisplayCurrentRecord FAtTop = True GoTo GoFirstEnd GoFirstError: ShowError Resume GoFirstEnd GoFirstEnd: ResetMouse Me MsgBar "", False End Sub Sub Form_Load () Dim t As TableDef 'local table structure Dim sp As Integer 'starting point of table name Dim ep As Integer 'ending point of table name Dim ds As String 'temp dynaset name string Dim wh As String 'where clause Dim ft As Integer Dim i As Integer, j As Integer Dim fn As String 'field name Dim l As Long On Error GoTo DynasetErr SetHourGlass Me MsgBar "Opening Dynaset", True 'assign the temp string with the select statement 'if it is not empty, otherwise, use the table list name If gfFromSQL = True Then If gstDynaString = "" Then ds = fSQL.cSQLStatement Else ds = gstDynaString End If Else ds = fTables.cTableList End If 'attemp to open the dynaset Set FDS = gCurrentDB.CreateDynaset(ds) 'parse off table name to store in global gstTblName wh = "" sp = InStr(1, UCase(ds), "FROM") If sp > 0 Then 'must be a "select from" statement sp = sp + 5 For ep = sp To Len(ds) 'search for a space or the end of ds If Mid$(ds, ep, 1) = " " Then 'get where clause if there is one wh = Mid$(ds, sp, Len(ds) - sp + 1) Exit For End If Next FTblName = UCase(Mid$(ds, sp, ep - sp)) If wh = "" Then wh = FTblName Else 'must be a table name only FTblName = UCase(ds) wh = FTblName End If FDynaString = wh 'show the first record FNumbRows = GetNumbRecs(FDS, wh) 'query numb of recs 'load the controls on the dynaset form cFieldName(0).Visible = True cFieldData(0).Visible = True ft = FDS(0).Type cFieldData(0).Width = GetFieldWidth(ft) cFieldData(0).TabIndex = 0 For i = 1 To FDS.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 = FDS(i).Type cFieldData(i).Width = GetFieldWidth(ft) cFieldData(i).TabIndex = i Next 'resize main window If i <= 10 Then Height = i * 300 + 1400 Else Height = 4368 Width = Width + 260 cScrollBar.Visible = True cScrollBar.Min = 720 cScrollBar.Max = 720 - (i * 300) + 3000 End If 'display the field names If gfFromSQL = False Or InStr(1, ds, "*") > 1 Then For i = 0 To FDS.Fields.Count - 1 cFieldName(i) = UCase(FDS(i).Name) + ":" Next Else 'parse off field names j = 8 For i = 0 To FDS.Fields.Count - 1 fn = "" While Mid(ds, j, 1) <> "," And Mid(ds, j, 1) <> " " fn = fn + Mid(ds, j, 1) j = j + 1 Wend While Mid(ds, j, 1) = "," Or Mid(ds, j, 1) = " " j = j + 1 Wend cFieldName(i) = UCase(fn) + ":" Next End If FCurrRec = 1 DisplayCurrentRecord 'display field values FAtTop = True Caption = "Dynaset: " + FTblName Width = 5430 Left = 1000 Top = 1000 GoTo OkayEnd DynasetErr: ShowError Unload Me Exit Sub Resume OkayEnd OkayEnd: ResetMouse Me MsgBar "", False End Sub Sub Form_Resize () 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 - 1368) Mod 300 <> 0 Then Height = ((h - 1368) \ 300) * 300 + 1368 End If 'resize the status bar StatBox.Top = Height - 650 'resize the scrollbar cScrollBar.Height = StatBox.Top - (ViewButtons.Top - FieldHeader.Height) - 980 cScrollBar.Left = Width - 360 If FDS.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 FDS.Fields.Count - 1 cFieldName(i).Width = .3 * totw cFieldData(i).Left = cFieldName(i).Width + 20 If FDS(i).Type = FT_STRING Or FDS(i).Type = FT_MEMO Then cFieldData(i).Width = .7 * totw - 250 End If Next FieldValueLabel.Left = cFieldData(0).Left End If MsgBar "", False End Sub Sub Form_Unload (Cancel As Integer) On Error Resume Next Unload FFindForm 'get rid of attached find form FDS.Close 'close the form dynaset MsgBar "", False End Sub Sub NextButton_Click () On Error GoTo GoNextError If FDS.EOF = True Then MsgBox "EOF Set, Going to First Row.", 48 GoTo EmptyDynaOnNext End If FDS.MoveNext 'show the current record FCurrRec = FCurrRec + 1 'bump the record counter DisplayCurrentRecord FAtTop = False GoTo GoNextEnd GoNextError: ShowError Resume GoNextEnd EmptyDynaOnNext: Call FirstButton_Click GoNextEnd: End Sub Sub PropButton_Click () Dim f As New fDataBox Dim s As String On Error GoTo DynPropErr f.cData.AddItem "Name = " + FDS.Name f.Caption = "Dynaset Properties" f.Top = Top + 700 f.Left = Left + 100 'set the value of the EOF flag If FDS.EOF Then s = TRUE_ST Else s = FALSE_ST End If f.cData.AddItem "EOF Flag = " + s 'set the value of the updatable flag If FDS.Updatable Then s = TRUE_ST Else s = FALSE_ST End If f.cData.AddItem "Updatable = " + s 'set the value of the transactions flag If FDS.Transactions Then s = TRUE_ST Else s = FALSE_ST End If f.cData.AddItem "Transactions = " + s f.Show GoTo DynPropEnd DynPropErr: ShowError Resume DynPropEnd DynPropEnd: End Sub Sub UpdateButton_Click () On Error GoTo UpdateErr FDS.Update If gfTransPending Then gfDBChanged = True If FAddNewFlag = True Then If FNumbRows = 0 Then 'special case for empty dynaset 'reopens the dynaset so we are on the 'newly added record GoTo EmptyDyn End If FNumbRows = FNumbRows + 1 FCurrRec = FNumbRows End If DisplayCurrentRecord ChangeButtons.Visible = False ViewButtons.Visible = True FEditFlag = False FAddNewFlag = False GoTo UpdateEnd UpdateErr: ShowError Resume UpdateEnd EmptyDyn: ChangeButtons.Visible = False ViewButtons.Visible = True FEditFlag = False FAddNewFlag = False Call FirstButton_Click UpdateEnd: End Sub