Liren Large Software Subsidy 10

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

/ Liren Large Software Subsidy 10 / 10.iso / l / l405 / 4.ddi / DYNAGRID.FR_ / DYNAGRID.bin

(.txt)

Wrap

Visual Basic Form | 1993-04-28 | 17.4 KB | 580 lines

VERSION 2.00 Begin Form fGridFrm BackColor = &H00C0C0C0& ClientHeight = 3105 ClientLeft = 930 ClientTop = 3585 ClientWidth = 6690 Height = 3510 Icon = DYNAGRID.FRX:0000 Left = 870 LinkTopic = "Form1" MDIChild = -1 'True ScaleHeight = 3096 ScaleMode = 0 'User ScaleWidth = 6708 Tag = "Dynaset" Top = 3240 Width = 6810 Begin Grid cGrid FixedCols = 0 FixedRows = 0 Height = 2412 Left = 0 TabIndex = 0 Top = 480 Width = 6732 End Begin PictureBox ViewButtons BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 375 Left = 0 ScaleHeight = 372 ScaleMode = 0 'User ScaleWidth = 5171.607 TabIndex = 1 Top = 24 Width = 5175 Begin CommandButton SortButton Caption = "&Sort" Height = 372 Left = 3720 TabIndex = 9 Top = 0 Width = 612 End Begin CommandButton FilterButton Caption = "Fil&ter" Height = 372 Left = 3120 TabIndex = 8 Top = 0 Width = 612 End Begin CommandButton RefreshButton Caption = "&Redo" Height = 372 Left = 2520 TabIndex = 7 Top = 0 Width = 612 End Begin CommandButton CloseButton Cancel = -1 'True Caption = "&Close" Height = 372 Left = 4320 TabIndex = 6 Top = 0 Width = 612 End Begin CommandButton MoreButton Caption = "&More" Height = 372 Left = 1320 TabIndex = 5 Top = 0 Width = 612 End Begin CommandButton NextButton Caption = "&Next" Height = 372 Left = 120 TabIndex = 4 Top = 0 Width = 612 End Begin CommandButton FirstButton Caption = "&First" Height = 372 Left = 720 TabIndex = 3 Top = 0 Width = 612 End Begin CommandButton FindButton Caption = "F&ind" Height = 372 Left = 1920 TabIndex = 2 Top = 0 Width = 612 End End Option Explicit 'form variables 'Dim FDS As dynaset 'current form's dynaset Dim FDS As snapshot 'current form's snapshot Dim FDynSt As String 'dynaset open string Dim FTblName As String 'form dynaset table name Dim FCurrentRow As Long 'current row in dynaset Dim FGridRow As Integer 'current grid row Dim FNotFound As Integer 'find not found flag Dim FFindForm As New fFind 'find form Dim FNumbRows As Long 'total number of rows in table Dim FDynaString As String 'dynaset open string Sub cGrid_DblClick () Dim r As Integer 'return from execute sql Dim fn As String 'field name On Error GoTo ZoomErr r = cGrid.Row cGrid.Row = 0 'get field name fn = cGrid.Text cGrid.Row = r 'make sure it's a string or memo field If FDS(fn).Type = FT_STRING Or FDS(fn).Type = FT_MEMO Then gstZoomData = cGrid.Text fZoom.Caption = fn fZoom.Top = Top + 1200 fZoom.Left = Left + 250 fZoom.CloseZoomButton.Visible = True fZoom.Show MODAL End If GoTo ZoomEnd ZoomErr: ShowError Resume ZoomEnd ZoomEnd: End Sub Sub cGrid_KeyUp (KeyCode As Integer, Shift As Integer) 'zoom on F4 key press If KeyCode = &H73 Then 'F4 cGrid_DblClick End If End Sub Sub CloseButton_Click () Unload Me End Sub Sub FilterButton_Click () On Error GoTo FilterErr ' Dim ds1 As dynaset, ds2 As dynaset Dim ds1 As snapshot, ds2 As snapshot Dim FilterStr As String Dim numbrows As Long 'local number of rows Set ds1 = FDS 'save the dynaset FilterStr = InputBox("Enter Filter Expression:") If FilterStr = "" Then Exit Sub FDS.Filter = FilterStr ' Set ds2 = FDS.CreateDynaset() 'establish the filter Set ds2 = FDS.CreateSnapshot() 'establish the filter Set FDS = ds2 'assign back to original dynaset object 'everything must be okay so redisplay form on 1st record FNumbRows = GetNumbRecsSS(FDS) 'query numb of recs If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical Caption = "Dynaset: " + FTblName numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 Unload Me Exit Sub ElseIf FNumbRows > gwMaxGridRows Then Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " rows]" End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me Exit Sub End If GoTo FilterEnd FilterErr: ShowError Set FDS = ds1 're-assign back to original Resume FilterEnd FilterEnd: End Sub Sub FindButton_Click () Dim i As Integer, r As Integer, c As Integer On Error GoTo FindErr 'load the column names into the find form 'the 1st time it is loaded If FFindForm.cFieldList.ListCount = 0 Then FFindForm.cFieldList.Clear r = cGrid.Row c = cGrid.Col cGrid.Row = 0 cGrid.Col = 0 For i = 1 To cGrid.Cols - 1 cGrid.Col = cGrid.Col + 1 FFindForm.cFieldList.AddItem cGrid.Text Next cGrid.Row = r cGrid.Col = c End If FindStart: 'used to loop around on not found 'reset the flags gfFindFailed = False gfFromTableView = True MsgBar "Enter Search Parameters", False FFindForm.Show MODAL MsgBar "Searching for record", True If gfFindFailed = True Then Exit Sub FNotFound = False SetHourglass Me 'search for the record cGrid.SetFocus 'start at the top SendKeys "^{Home}" cGrid.Col = 1 cGrid.Row = 0 'move the right column While cGrid.Text <> UCase(gstFindField) If cGrid.Col = cGrid.Cols Then 'reached max col Else cGrid.Col = cGrid.Col + 1 SendKeys "{Right}" End If Wend cGrid.Row = 1 While cGrid.Row < cGrid.Rows - 1 If gfFindMatch = False Then Select Case gstFindOp Case "=" If UCase(cGrid.Text) = UCase(gstFindExpr) Then GoTo AfterWhile Case "<>" If UCase(cGrid.Text) <> UCase(gstFindExpr) Then GoTo AfterWhile Case ">=" If UCase(cGrid.Text) >= UCase(gstFindExpr) Then GoTo AfterWhile Case "<=" If UCase(cGrid.Text) <= UCase(gstFindExpr) Then GoTo AfterWhile Case ">" If UCase(cGrid.Text) > UCase(gstFindExpr) Then GoTo AfterWhile Case "<" If UCase(cGrid.Text) < UCase(gstFindExpr) Then GoTo AfterWhile Case "Like" If UCase(cGrid.Text) Like UCase(gstFindExpr) Then GoTo AfterWhile End Select Else Select Case gstFindOp Case "=" If cGrid.Text = gstFindExpr Then GoTo AfterWhile Case "<>" If cGrid.Text <> gstFindExpr Then GoTo AfterWhile Case ">=" If cGrid.Text >= gstFindExpr Then GoTo AfterWhile Case "<=" If cGrid.Text <= gstFindExpr Then GoTo AfterWhile Case ">" If cGrid.Text > gstFindExpr Then GoTo AfterWhile Case "<" If cGrid.Text < gstFindExpr Then GoTo AfterWhile Case "Like" If cGrid.Text Like gstFindExpr Then GoTo AfterWhile End Select End If cGrid.Row = cGrid.Row + 1 SendKeys "{Down}" Wend FNotFound = True 'didn't find it AfterWhile: ResetMouse Me 'show the first record If FNotFound Then Beep MsgBox "Record Not Found", 48 GoTo FindStart End If DoEvents cGrid.SelStartRow = cGrid.Row cGrid.SelStartCol = 1 cGrid.SelEndRow = cGrid.Row cGrid.SelEndCol = FDS.Fields.Count GoTo FindEnd FindErr: ResetMouse Me ShowError Resume FindEnd FindEnd: MsgBar "", False End Sub Sub FirstButton_Click () Dim numbrows As Long 'number of rows On Error GoTo GoFirstError SetHourglass Me MsgBar "Going to first record", True cGrid.SetFocus cGrid.Row = 1 cGrid.Col = 0 'get current starting row in grid If cGrid.Text <> "1" Then FDS.Close ' Set FDS = gCurrentDB.CreateDynaset(FDS.Name) Set FDS = gCurrentDB.CreateSnapshot(FDS.Name) FNumbRows = GetNumbRecsSS(FDS) If FNumbRows > gwMaxGridRows Then numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me Exit Sub End If End If cGrid.Col = 1 SendKeys "{Home}" 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 wh As String 'where clause Dim i As Integer, j As Integer Dim fn As String 'field name Dim rc As Integer 'record count Dim numbrows As Long 'local number of rows Dim ss As snapshot Dim Start1, Finish1, Start2, Finish2 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 FDynSt = fSQL.cSQLStatement Else FDynSt = gstDynaString End If Else FDynSt = fTables.cTableList End If 'attemp to open the dynaset Start1 = Timer If UCase(FDynSt) = "LISTTABLES" Then Set FDS = gCurrentDB.ListTables() Else If gfFromSQL = True And fSQL.cPassThru = 1 Then ' Set FDS = gCurrentDB.CreateDynaset(FDynSt, VBDA_SQLPASSTHROUGH) Set FDS = gCurrentDB.CreateSnapshot(FDynSt, VBDA_SQLPASSTHROUGH) Else ' Set FDS = gCurrentDB.CreateDynaset(FDynSt) Set FDS = gCurrentDB.CreateSnapshot(FDynSt) End If End If Finish1 = Timer Start2 = Timer 'parse off table name to store in global gstTblName wh = "" sp = InStr(1, UCase(FDynSt), "FROM") If sp > 0 Then 'must be a "select from" statement sp = sp + 5 For ep = sp To Len(FDynSt) 'search for a space or the end of FDynSt If Mid$(FDynSt, ep, 1) = " " Then 'get where clause if there is one wh = Mid$(FDynSt, sp, Len(FDynSt) - sp + 1) Exit For End If Next FTblName = UCase(Mid$(FDynSt, sp, ep - sp)) If wh = "" Then wh = FTblName Else 'must be a table name only FTblName = UCase(FDynSt) wh = FTblName End If FDynaString = wh 'show the first record FNumbRows = GetNumbRecsSS(FDS) 'query numb of recs If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical Caption = "SnapShot: " + FTblName numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 Unload Me Exit Sub ElseIf FNumbRows > gwMaxGridRows Then Caption = "SnapShot: " + FTblName + " [" + CStr(FNumbRows) + " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows Caption = "SnapShot: " + FTblName + " [" + CStr(FNumbRows) + " rows]" End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me Exit Sub End If Height = 3800 Width = 5300 Left = 1000 Top = 1000 Finish2 = Timer If VDMDI.PrefShowPerf.Checked Then Me.Show MsgBox CStr(FNumbRows) + " rows found in " + CStr(Finish1 - Start1) + " seconds!" + Chr(13) + Chr(10) + CStr(Finish2 - Start2) + " seconds to Load Grid!", 48 End If GoTo OkayEnd DynasetErr: ShowError ResetMouse Me MsgBar "", False Unload Me Exit Sub Resume OkayEnd OkayEnd: ResetMouse Me MsgBar "", False End Sub Sub Form_Resize () On Error Resume Next 'resize grid to window If WindowState <> 1 Then 'not minimized cGrid.Height = Height - 900 cGrid.Width = Width - 100 End If End Sub Sub Form_Unload (Cancel As Integer) On Error Resume Next 'unload the find form Unload FFindForm 'close the associated dynaset FDS.Close MsgBar "", False End Sub Sub MoreButton_Click () Dim ret As Integer 'return value from loadgrid On Error Resume Next MsgBar "Getting more records", True If FDS.EOF <> True Then SetHourglass Me ret = LoadGrid(cGrid, FDS, FDynSt, gwMaxGridRows, FCurrentRow) If ret = False Then 'failed so bail out of form FDS.Close Unload Me End If 'set new current row FCurrentRow = FCurrentRow + ret ResetMouse Me End If MsgBar "", False End Sub Sub NextButton_Click () Dim c As Integer 'current column On Error GoTo GoNextError c = cGrid.Col cGrid.Col = 0 If cGrid.Text = "" Then Beep ElseIf cGrid.Row = gwMaxGridRows Then MoreButton_Click Else cGrid.SetFocus SendKeys "{Down}" End If cGrid.Col = c GoTo GoNextEnd GoNextError: ShowError Resume GoNextEnd GoNextEnd: End Sub 'needed for multi-user situations so 'new records can be viewed imediately Sub RefreshButton_Click () Dim numbrows As Long On Error GoTo RefreshError MsgBar "Reopening Dynaset", True SetHourglass Me ' Set FDS = gCurrentDB.CreateDynaset(FDS.Name) Set FDS = gCurrentDB.CreateSnapshot(FDS.Name) FNumbRows = GetNumbRecsSS(FDS) If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical Caption = "Dynaset: " + FTblName numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 Unload Me ElseIf FNumbRows > gwMaxGridRows Then Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " rows]" End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me Exit Sub End If GoTo RefreshEnd RefreshError: ShowError Resume RefreshEnd RefreshEnd: ResetMouse Me MsgBar "", False End Sub Sub SortButton_Click () On Error GoTo SortErr ' Dim ds1 As dynaset, ds2 As dynaset Dim ds1 As snapshot, ds2 As snapshot Dim SortStr As String Dim numbrows As Long 'local number of rows Set ds1 = FDS 'save the dynaset SortStr = InputBox("Enter Sort Column:") If SortStr = "" Then Exit Sub FDS.Sort = SortStr ' Set ds2 = FDS.CreateDynaset() 'establish the Sort Set ds2 = FDS.CreateSnapshot() 'establish the Sort Set FDS = ds2 'assign back to original dynaset object 'everything must be okay so redisplay form on 1st record FNumbRows = GetNumbRecsSS(FDS) 'query numb of recs If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical Caption = "Dynaset: " + FTblName numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 Unload Me Exit Sub ElseIf FNumbRows > gwMaxGridRows Then Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " rows]" End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me Exit Sub End If GoTo SortEnd SortErr: ShowError Set FDS = ds1 're-assign back to original Resume SortEnd SortEnd: End Sub