Visual Basic Toolbox

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

/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / query / mquery / mdynast.frm (.txt) next >

Wrap

Visual Basic Form | 1994-05-24 | 25.6 KB | 875 lines

VERSION 2.00 Begin Form fDynaset AutoRedraw = -1 'True BackColor = &H00C0C0C0& ClientHeight = 3750 ClientLeft = 1410 ClientTop = 2415 ClientWidth = 5655 ClipControls = 0 'False Height = 4155 Icon = MDYNAST.FRX:0000 KeyPreview = -1 'True Left = 1350 LinkTopic = "Form1" MinButton = 0 'False ScaleHeight = 3733.906 ScaleMode = 0 'User ScaleWidth = 5675.317 Tag = "Dynaset" Top = 2070 Width = 5775 Begin PictureBox FieldHeader BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 240 Left = 0 ScaleHeight = 240 ScaleMode = 0 'User ScaleWidth = 5028 TabIndex = 15 Top = 480 Width = 5025 Begin Label FieldHdrLabel BackColor = &H00C0C0C0& Caption = "Field Name:" Height = 252 Left = 120 TabIndex = 16 Top = 0 Width = 1212 End End Begin PictureBox ViewButtons Align = 1 'Align Top BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 495 Left = 0 ScaleHeight = 495 ScaleMode = 0 'User ScaleWidth = 5658.376 TabIndex = 0 Top = 0 Width = 5655 Begin CommandButton SortButton Caption = "&Sort" Height = 330 Left = 3128 TabIndex = 17 Top = 0 Width = 650 End Begin CommandButton FilterButton Caption = "F&ilter" Height = 330 Left = 2520 TabIndex = 22 Top = 0 Width = 650 End Begin CommandButton CloseButton Cancel = -1 'True Caption = "&Close" Height = 330 Left = 3780 TabIndex = 8 TabStop = 0 'False Top = 0 Width = 650 End Begin CommandButton DelButton Caption = "&Del" Height = 330 Left = 1260 TabIndex = 4 Top = 0 Width = 650 End Begin CommandButton EditButton Caption = "&Edit" Height = 330 Left = 630 TabIndex = 3 Top = 0 Width = 650 End Begin CommandButton AddButton Caption = "&Add" Height = 330 Left = 0 TabIndex = 2 Top = 0 Width = 650 End Begin CommandButton FindButton Caption = "&Find" Height = 330 Left = 1890 TabIndex = 1 Top = 0 Width = 650 End End Begin PictureBox ChangeButtons BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 480 Left = 0 ScaleHeight = 480 ScaleMode = 0 'User ScaleWidth = 5028 TabIndex = 5 Top = 0 Visible = 0 'False Width = 5028 Begin CommandButton UpdateButton Caption = "&Update" Height = 372 Left = 960 TabIndex = 7 Top = 48 Width = 1212 End Begin CommandButton CancelButton Caption = "&Cancel" Height = 372 Left = 2640 TabIndex = 6 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 = 13 Top = 3465 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 = 21 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 = 20 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 = 19 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 = 18 Top = 0 Width = 375 End Begin Label cStatusBar BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Height = 287 Left = 749 TabIndex = 14 Top = 5 Width = 3360 End End Begin VScrollBar cScrollBar Height = 2616 LargeChange = 3000 Left = 5040 SmallChange = 300 TabIndex = 12 Top = 720 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 = 9 Top = 720 Width = 4815 Begin TextBox cFieldData BackColor = &H00FFFFFF& DataSource = "Data1" ForeColor = &H00000000& Height = 288 Index = 0 Left = 1560 TabIndex = 10 Top = 0 Visible = 0 'False Width = 3252 End Begin Label cFieldName BackColor = &H00C0C0C0& ForeColor = &H00000000& Height = 252 Index = 0 Left = 0 TabIndex = 11 Top = 60 Visible = 0 'False Width = 1572 End End Option Explicit 'form variables Dim FDS As dynaset 'current form's dynaset 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 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 'set the mode FDS.AddNew cStatusBar = "Add record" FAddNewFlag = True If FDS.RecordCount > 0 Then FBM = FDS.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 FDS.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 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 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 () If Not gStoredFlag Then ' this query did not come from storage fQuery.RunSaveQryButton.Caption = "&Store Query " fQuery.RunSaveQryButton.Enabled = True fQuery.RunQueryButton.Enabled = False Else fQuery.RunSaveQryButton.Caption = "&Load Query" fQuery.RunSaveQryButton.Enabled = False fQuery.RunQueryButton.Enabled = False 'gStoredFlag = False End If fQuery.Show 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 gstDynaString = "" 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 = "Record " 'check BOF/EOF flag so we know if we 'are sitting on a valid record If FAddNewFlag = True Then cst = cst + CStr(FCurrRec) + " of " + CStr(FNumbRows) Else If FDS.BOF = True Then cst = cst + "(BOF) of " + CStr(FNumbRows) ClearDataFields ElseIf FDS.EOF = True Then cst = cst + "(EOF) of " + CStr(FNumbRows) ClearDataFields Else cst = cst + CStr(FCurrRec) + " of " + 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 gstDynaString = "" Resume DCREnd DCREnd: ResetMouse Me End Sub Sub EditButton_Click () On Error GoTo EditErr FDS.Edit cStatusBar = "Edit record" FEditFlag = True cFieldData(0).SetFocus FBM = FDS.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 bm As String Dim ds1 As dynaset, ds2 As dynaset Dim i As Integer bm = FDS.Bookmark 'save the bookmark Set ds1 = FDS 'save the dynaset fFIlter.cExpr.Text = "" fFIlter.cFieldList.Clear For i = 0 To FDS.Fields.Count - 1 fFIlter.cFieldList.AddItem Mid(cFieldName(i), 1, Len(cFieldName(i)) - 1) Next MsgBar "Enter Search Parameters", False fFIlter.Show MODAL 'gFilterStr = InputBox("Enter Filter Expression:") If gFilterStr = "" Then Exit Sub SetHourGlass Me MsgBar "Setting New Filter", True FDS.Filter = gFilterStr Set ds2 = FDS.CreateDynaset() 'establish the filter Set FDS = ds2 'assign back to original dynaset object 'everything must be okay so redisplay form on 1st record FNumbRows = GetNumbRecs(FDS) 'query numb of recs FCurrRec = 1 DisplayCurrentRecord 'display field values FAtTop = True ResetMouse Me MsgBar "", False GoTo FilterEnd FilterErr: ResetMouse Me MsgBar "", False ShowError Set FDS = ds1 're-assign back to original FDS.Bookmark = bm 'go back to original record Resume FilterEnd FilterEnd: End Sub Sub FindButton_Click () Dim i As Integer Dim bm As String 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 i = FFindForm.cFieldList.ListIndex 'search for the record bm = FDS.Bookmark If FDS(i).Type = FT_STRING Or FDS(i).Type = FT_MEMO Then FDS.FindFirst FDS(i).Name + " " + gstFindOp + " '" + gstFindExpr + "'" Else FDS.FindFirst FDS(i).Name + gstFindOp + gstFindExpr End If FNotFound = FDS.NoMatch AfterWhile: ResetMouse Me If gfFindFailed = True Then 'go back to top FDS.Bookmark = bm ElseIf FNotFound Then Beep MsgBox "Record Not Found", 48 FDS.Bookmark = bm GoTo FindStart Else bm = FDS.Bookmark FDS.MoveFirst FCurrRec = 1 While FDS.Bookmark <> bm FCurrRec = FCurrRec + 1 FDS.MoveNext Wend End If DisplayCurrentRecord GoTo FindEnd FindErr: ResetMouse Me If Err <> EOF_ERR Then ShowError gstDynaString = "" Resume FindEnd Else FNotFound = True Resume Next End If FindEnd: MsgBar "", False End Sub Sub FirstButton_Click () Dim ds As String On Error GoTo GoFirstError FDS.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 Case 114 'F3 Call FindButton_Click End Select 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 If gfFromSQL = True Then ds = fQuery!cCriteria If gfFromSQL Then ' from SQL Statement gstDynaString = fQuery!cCriteria ' so we can store End If Else ds = gstDynaString 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)) gTblname = FTblname ' global for filter and sort 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) '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.Fields(i).Type cFieldData(i).Width = GetFieldWidth(ft) cFieldData(i).TabIndex = i Next 'resize main window If i <= 10 Then Height = ((i + 1) * 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 For i = 0 To FDS.Fields.Count - 1 cFieldName(i) = UCase(FDS(i).Name) + ":" Next FCurrRec = 1 DisplayCurrentRecord 'display field values FAtTop = True ' Caption = "Dynaset: " + FTblname Me.Left = (screen.Width - Me.Width) / 2 Me.Top = (screen.Height - Me.Height) / 2 'Width = 5805 'Left = 1000 'Top = 1000 Me.Show fQuery.Hide GoTo OkayEnd DynasetErr: ShowError ResetMouse Me gstDynaString = "" Unload Me fQuery.Show 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 - 1420) Mod 300 <> 0 Then Height = ((h - 1420) \ 300) * 300 + 1420 End If 'resize the status bar StatBox.Top = Height - 650 'resize the scrollbar cScrollBar.Height = StatBox.Top - (ViewButtons.Top - FieldHeader.Height) - 960 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 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 'gstDynaString = "" Unload FFindForm 'get rid of attached find form FDS.Close 'close the form dynaset MsgBar "", False End Sub Sub LastButton_Click () On Error GoTo GoLastError FDS.MoveLast 'show the current record FCurrRec = FNumbRows DisplayCurrentRecord GoTo GoLastEnd GoLastError: ShowError Resume GoLastEnd GoLastEnd: End Sub Sub NextButton_Click () On Error GoTo GoNextError FDS.MoveNext 'show the current record FCurrRec = FCurrRec + 1 'bump the record counter DisplayCurrentRecord FAtTop = False GoTo GoNextEnd GoNextError: ShowError Resume GoNextEnd GoNextEnd: End Sub Sub PrevButton_Click () On Error GoTo GoPrevError FDS.MovePrevious 'show the current record FCurrRec = FCurrRec - 1 'bump the record counter back DisplayCurrentRecord FAtTop = False GoTo GoPrevEnd GoPrevError: ShowError Resume GoPrevEnd GoPrevEnd: End Sub Sub SortButton_Click () On Error GoTo SortErr Dim bm As String Dim ds1 As dynaset, ds2 As dynaset Dim i As Integer gSortStr = "" bm = FDS.Bookmark 'save the bookmark Set ds1 = FDS 'save the dynaset fSort.cFieldList.Clear For i = 0 To FDS.Fields.Count - 1 fSort.cFieldList.AddItem Mid(cFieldName(i), 1, Len(cFieldName(i)) - 1) Next fSort.Show MODAL 'gSortStr = InputBox("Enter Sort Column:") If gSortStr = "" Then Exit Sub SetHourGlass Me MsgBar "Setting New Sort Order", True FDS.Sort = gSortStr Set ds2 = FDS.CreateDynaset() 'establish the Sort Set FDS = ds2 'assign back to original dynaset object 'everything must be okay so redisplay form on 1st record FNumbRows = GetNumbRecs(FDS) 'query numb of recs FCurrRec = 1 DisplayCurrentRecord 'display field values FAtTop = True ResetMouse Me MsgBar "", False GoTo SortEnd SortErr: ResetMouse Me MsgBar "", False ShowError Set FDS = ds1 're-assign back to original FDS.Bookmark = bm 'go back to original record Resume SortEnd SortEnd: End Sub Sub UpdateButton_Click () On Error GoTo UpdateErr FDS.Update If gfTransPending Then gfDBChanged = True If FAddNewFlag = True Then FNumbRows = FNumbRows + 1 FCurrRec = FNumbRows FDS.MoveLast 'move to the new record End If ChangeButtons.Visible = False ViewButtons.Visible = True NextButton.Enabled = True FirstButton.Enabled = True LastButton.Enabled = True PrevButton.Enabled = True FEditFlag = False FAddNewFlag = False DisplayCurrentRecord GoTo UpdateEnd UpdateErr: ShowError Resume UpdateEnd UpdateEnd: End Sub