Master 95 #1

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

/ Master 95 #1 / MASTER95_1.iso / microsof / vbasic4 / vb4-6.cab / dynasnap.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1995-07-26 | 32.3 KB | 948 lines

VERSION 4.00 Begin VB.Form frmDynaSnap ClientHeight = 3750 ClientLeft = 1845 ClientTop = 2130 ClientWidth = 5460 Height = 4155 HelpContextID = 2016125 Icon = "DYNASNAP.frx":0000 KeyPreview = -1 'True Left = 1785 LinkTopic = "Form1" LockControls = -1 'True MDIChild = -1 'True ScaleHeight = 3733.906 ScaleMode = 0 'User ScaleWidth = 5479.612 Tag = "Recordset" Top = 1785 Width = 5580 Begin VB.PictureBox picViewButtons Align = 1 'Align Top Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 855 Left = 0 ScaleHeight = 855 ScaleMode = 0 'User ScaleWidth = 5463.258 TabIndex = 14 TabStop = 0 'False Top = 0 Width = 5460 Begin VB.CommandButton cmdMove Caption = "&Move" Height = 345 Left = 1080 TabIndex = 8 TabStop = 0 'False Top = 360 Width = 1095 End Begin VB.CommandButton cmdSort Caption = "&Sort" Height = 345 Left = 0 TabIndex = 6 Top = 360 Width = 1095 End Begin VB.CommandButton cmdFilter Caption = "F&ilter" Height = 345 Left = 4320 TabIndex = 5 Top = 20 Width = 1095 End Begin VB.CommandButton cmdClose Caption = "&Close" Height = 345 Left = 3240 TabIndex = 9 TabStop = 0 'False Top = 360 Width = 1095 End Begin VB.CommandButton cmdProperties Caption = "&Prop" Height = 345 Left = 2160 TabIndex = 7 Top = 360 Width = 1095 End Begin VB.CommandButton cmdDelete Caption = "&Delete" Height = 345 Left = 2160 TabIndex = 3 Top = 20 Width = 1095 End Begin VB.CommandButton cmdEdit Caption = "&Edit" Height = 345 Left = 1080 TabIndex = 2 Top = 20 Width = 1095 End Begin VB.CommandButton cmdAdd Caption = "&Add" Height = 345 Left = 0 TabIndex = 1 Top = 20 Width = 1095 End Begin VB.CommandButton cmdFind Caption = "&Find" Height = 345 Left = 3240 TabIndex = 4 Top = 20 Width = 1095 End End Begin VB.PictureBox picChangeButtons Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 855 Left = 0 ScaleHeight = 919.528 ScaleMode = 0 'User ScaleWidth = 5719.056 TabIndex = 15 TabStop = 0 'False Top = 0 Visible = 0 'False Width = 5655 Begin VB.CommandButton cmdUpdate Caption = "&Update" Height = 372 Left = 960 TabIndex = 12 Top = 48 Width = 1212 End Begin VB.CommandButton cmdCancel Caption = "&Cancel" Height = 372 Left = 2640 TabIndex = 13 Top = 48 Width = 1212 End End Begin VB.PictureBox picFldHdr Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 240 Left = 0 ScaleHeight = 240 ScaleMode = 0 'User ScaleWidth = 14948.92 TabIndex = 19 TabStop = 0 'False Top = 840 Width = 14946 Begin VB.Label lblFieldValue Caption = " Value (F4=Zoom)" Height = 255 Left = 1680 TabIndex = 21 Top = 0 Width = 2295 End Begin VB.Label lblFieldHdr Caption = "Field Name:" Height = 252 Left = 120 TabIndex = 20 Top = 0 Width = 1212 End End Begin VB.PictureBox picMoveButtons Align = 2 'Align Bottom Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 285 Left = 0 ScaleHeight = 298.153 ScaleMode = 0 'User ScaleWidth = 5469.835 TabIndex = 18 TabStop = 0 'False Top = 3465 Width = 5460 Begin VB.HScrollBar hsclCurrRow Height = 255 Left = 0 Max = 100 TabIndex = 10 Top = 29 Width = 2895 End Begin VB.Label lblStatus Height = 255 Left = 3000 TabIndex = 22 Top = 38 Width = 1695 End End Begin VB.VScrollBar vsbScrollBar Height = 2250 LargeChange = 3000 Left = 5040 SmallChange = 300 TabIndex = 11 Top = 1080 Visible = 0 'False Width = 255 End Begin VB.PictureBox picFields Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 375 Left = 120 ScaleHeight = 372 ScaleMode = 0 'User ScaleWidth = 4812 TabIndex = 16 TabStop = 0 'False Top = 1080 Width = 4815 Begin VB.TextBox txtFieldData BackColor = &H00FFFFFF& DataSource = "Data1" ForeColor = &H00000000& Height = 288 Index = 0 Left = 1560 TabIndex = 0 Top = 0 Visible = 0 'False Width = 3252 End Begin VB.Label lblFieldName ForeColor = &H00000000& Height = 252 Index = 0 Left = 0 TabIndex = 17 Top = 60 Visible = 0 'False Width = 1572 End End Attribute VB_Name = "frmDynaSnap" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit 'form variables Dim mrecFormRecordset As Recordset 'current form's recordset Dim msTableName As String 'form recordset table name Dim msBookMark As String 'form bookmark Dim mbNotFound As Integer 'used by find function Dim mbEditFlag As Integer 'edit mode Dim mbAddNewFlag As Integer 'add mode Dim mbDataChanged As Integer 'field data dirty flag Dim mfrmFind As New frmFindForm 'find form instance Dim mlNumRows As Long 'total rows in recordset Private Sub cmdAdd_Click() On Error GoTo AddErr 'set the mode mrecFormRecordset.AddNew lblStatus.Caption = "Add record" mbAddNewFlag = True If mrecFormRecordset.RecordCount > 0 Then msBookMark = mrecFormRecordset.Bookmark Else msBookMark = gsNULL_STR End If picChangeButtons.Visible = True picViewButtons.Visible = False hsclCurrRow.Enabled = False ClearDataFields Me, mrecFormRecordset.Fields.Count txtFieldData(0).SetFocus mbDataChanged = False Exit Sub AddErr: ShowError Exit Sub End Sub Private Sub cmdCancel_Click() On Error Resume Next picChangeButtons.Visible = False picViewButtons.Visible = True hsclCurrRow.Enabled = True mbEditFlag = False mbAddNewFlag = False mrecFormRecordset.CancelUpdate DBEngine.Idle dbFreeLocks DisplayCurrentRecord Me, mrecFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False End Sub Private Sub cmdMove_Click() On Error GoTo MVErr Dim sBookMark As String Dim lRows As Long lRows = CLng(InputBox("Enter number of Rows to Move:" & gsNewLine & "(Use negative value to move backwards)")) If lRows = 0 Then Exit Sub mrecFormRecordset.Move lRows sBookMark = mrecFormRecordset.Bookmark 'save the new position 'now we need to reposition the scrollbar to reflect the move If mlNumRows > 32767 Then hsclCurrRow.VALUE = (mrecFormRecordset.PercentPosition * 32767) / 100 + 1 ElseIf mlNumRows > 99 Then hsclCurrRow.VALUE = (mrecFormRecordset.PercentPosition * mlNumRows) / 100 + 1 Else hsclCurrRow.VALUE = mrecFormRecordset.PercentPosition End If mrecFormRecordset.Bookmark = sBookMark Exit Sub MVErr: ShowError Exit Sub End Sub Private Sub hsclCurrRow_Change() On Error GoTo SCRErr Static nPrevVal As Integer 'based on number of rows, there is different logic needed 'to set the current position in the recordset If mlNumRows > 0 Then If mlNumRows > 32767 Then 'if there are > 32767 we need to use the move methods because 'the scrollbar is limited to 32767 so if we didn't apply this 'logic, it would be impossible to get to every record on a 'small change of the scrollbar If hsclCurrRow.VALUE - nPrevVal = 1 Then mrecFormRecordset.MoveNext ElseIf hsclCurrRow.VALUE - nPrevVal = -1 Then mrecFormRecordset.MovePrevious Else mrecFormRecordset.PercentPosition = (hsclCurrRow.VALUE / 32767) * 100 + 0.005 End If nPrevVal = hsclCurrRow.VALUE ElseIf mlNumRows > 99 Then 'need to calculate the position when there are > 99 recs mrecFormRecordset.PercentPosition = (hsclCurrRow.VALUE / mlNumRows) * 100 + 0.005 Else mrecFormRecordset.PercentPosition = hsclCurrRow.VALUE End If End If DisplayCurrentRecord Me, mrecFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False Screen.MousePointer = vbDefault MsgBar gsNULL_STR, False Exit Sub SCRErr: ShowError Exit Sub End Sub Private Sub txtFieldData_Change(Index As Integer) 'just set the flag if data is changed 'it gets reset to false when a new record is displayed mbDataChanged = True End Sub Private Sub txtFieldData_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer) If KeyCode = &H73 Then 'F4 lblFieldName_DblClick Index ElseIf KeyCode = 34 And vsbScrollBar.Visible = True Then 'pagedown with > 10 fields vsbScrollBar.VALUE = vsbScrollBar.VALUE - 3000 ElseIf KeyCode = 33 And vsbScrollBar.Visible = True Then 'pageup with > 10 fields vsbScrollBar.VALUE = vsbScrollBar.VALUE + 3000 End If End Sub Private Sub txtFieldData_KeyPress(Index As Integer, KeyAscii As Integer) 'only allow return when in edit of add mode If mbEditFlag = True Or mbAddNewFlag = True Then If KeyAscii = 13 Then KeyAscii = 0 SendKeys "{Tab}" End If 'throw away the keystrokes if not in add or edit mode ElseIf mbEditFlag = False And mbAddNewFlag = False Then KeyAscii = 0 End If End Sub Private Sub txtFieldData_LostFocus(Index As Integer) On Error GoTo FldDataErr If mbDataChanged = True Then 'store the data in the field mrecFormRecordset(Index) = txtFieldData(Index) End If 'reset for valid or error condition mbDataChanged = False Exit Sub FldDataErr: 'reset for valid or error condition mbDataChanged = False ShowError Exit Sub End Sub Private Sub lblFieldName_DblClick(Index As Integer) On Error GoTo ZoomErr If mrecFormRecordset(Index).Type = dbText Or mrecFormRecordset(Index).Type = dbMemo Then If mrecFormRecordset(Index).Type = dbText Then gsZoomData = txtFieldData(Index).TEXT ElseIf mrecFormRecordset(Index).FieldSize() < gnGETCHUNK_CUTOFF Then gsZoomData = txtFieldData(Index).TEXT Else 'add the rest of the field data with getchunk MsgBar "Getting Memo Field Data", True SetHourglass gsZoomData = txtFieldData(Index).TEXT & _ StripNonAscii(mrecFormRecordset(Index).GetChunk(gnGETCHUNK_CUTOFF, gnMAX_MEMO_SIZE)) Screen.MousePointer = vbDefault MsgBar gsNULL_STR, False End If frmZoom.Caption = Mid(lblFieldName(Index).Caption, 1, Len(lblFieldName(Index).Caption) - 1) If mbAddNewFlag Or mbEditFlag Then frmZoom.cmdSave.Visible = True frmZoom.cmdCloseNoSave.Visible = True Else frmZoom.cmdClose.Visible = True End If If mrecFormRecordset(Index).Type = dbText Then frmZoom.txtZoomData.TEXT = gsZoomData frmZoom.Height = 1125 Else frmZoom.txtMemo.TEXT = gsZoomData frmZoom.txtMemo.Visible = True frmZoom.txtZoomData.Visible = False frmZoom.Height = 2205 End If frmZoom.Show vbModal If (mbAddNewFlag Or mbEditFlag) And gsZoomData <> "__CANCELLED__" Then If mrecFormRecordset(Index).Type = dbText And Len(gsZoomData) > mrecFormRecordset(Index).Size Then Beep MsgBox "Field Length Exceeded, Data Truncated!", 48 txtFieldData(Index).TEXT = Mid(gsZoomData, 1, mrecFormRecordset(Index).Size) Else txtFieldData(Index).TEXT = gsZoomData End If mrecFormRecordset(Index) = txtFieldData(Index).TEXT mbDataChanged = False End If End If Exit Sub ZoomErr: ShowError Exit Sub End Sub Private Sub cmdClose_Click() DBEngine.Idle dbFreeLocks Unload Me End Sub Sub txtFieldData_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single) If Button <> 2 Then Exit Sub ShowProperties "Field", mrecFormRecordset.Fields(Index) End Sub Private Sub vsbScrollBar_Change() Dim nTop As Integer nTop = vsbScrollBar.VALUE If (nTop - 1080) Mod gnCTLARRAYHEIGHT = 0 Then picFields.TOP = nTop Else picFields.TOP = ((nTop - 1080) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + 1080 End If End Sub Private Sub cmdDelete_Click() On Error GoTo DelRecErr If MsgBox("Delete Current Record?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then mrecFormRecordset.DELETE If gbTransPending Then gbDBChanged = True If mrecFormRecordset.EOF = False Then mrecFormRecordset.MoveNext End If mlNumRows = mlNumRows - 1 SetScrollBar DisplayCurrentRecord Me, mrecFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False End If Exit Sub DelRecErr: ShowError Exit Sub End Sub Private Sub cmdEdit_Click() On Error GoTo EditErr Dim nDelay As Long Dim nRetryCnt As Integer SetHourglass RetryEdit: mrecFormRecordset.Edit lblStatus.Caption = "Edit record" mbEditFlag = True txtFieldData(0).SetFocus msBookMark = mrecFormRecordset.Bookmark picChangeButtons.Visible = True picViewButtons.Visible = False hsclCurrRow.Enabled = False Screen.MousePointer = vbDefault Exit Sub EditErr: If Err = 3260 And nRetryCnt < gnMURetryCnt Then nRetryCnt = nRetryCnt + 1 DBEngine.Idle dbFreeLocks 'Wait gnMUDelay seconds nDelay = Timer While Timer - nDelay < gnMUDelay 'do nothing Wend Resume RetryEdit Else ShowError Exit Sub End If End Sub Private Sub cmdFilter_Click() On Error GoTo FilterErr Dim sBookMark As String Dim recRecordset1 As Recordset, recRecordset2 As Recordset Dim sFilterStr As String sBookMark = mrecFormRecordset.Bookmark 'save the bookmark Set recRecordset1 = mrecFormRecordset 'save the recordset sFilterStr = InputBox("Enter Filter Expression:") If Len(sFilterStr) = 0 Then Exit Sub SetHourglass MsgBar "Setting New Filter", True mrecFormRecordset.Filter = sFilterStr Set recRecordset2 = mrecFormRecordset.OpenRecordset(mrecFormRecordset.Type) 'establish the filter Set mrecFormRecordset = recRecordset2 'assign back to original recordset object 'everything must be okay so redisplay form on 1st record mlNumRows = GetNumbRecs(mrecFormRecordset) 'query numb of recs SetScrollBar hsclCurrRow.VALUE = 0 DisplayCurrentRecord Me, mrecFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False Screen.MousePointer = vbDefault MsgBar gsNULL_STR, False Exit Sub FilterErr: ShowError Set mrecFormRecordset = recRecordset1 're-assign back to original mrecFormRecordset.Bookmark = sBookMark 'go back to original record Exit Sub End Sub Private Sub cmdFind_Click() On Error GoTo FindErr Dim i As Integer Dim sBookMark As String Dim sTmp As String 'load the column names into the find form If mfrmFind.lstFields.ListCount = 0 Then For i = 0 To mrecFormRecordset.Fields.Count - 1 mfrmFind.lstFields.AddItem Mid(lblFieldName(i).Caption, 1, Len(lblFieldName(i).Caption) - 1) Next End If FindStart: 'reset the flags gbFindFailed = False gbFromTableView = False mbNotFound = False MsgBar "Enter Search Parameters", False mfrmFind.Show vbModal MsgBar "Searching for New Record", True If gbFindFailed = True Then 'find cancelled GoTo AfterWhile End If SetHourglass i = mfrmFind.lstFields.ListIndex sBookMark = mrecFormRecordset.Bookmark 'search for the record If mrecFormRecordset(i).Type = dbText Or mrecFormRecordset(i).Type = dbMemo Then sTmp = AddBrackets((mrecFormRecordset(i).Name)) & " " & gsFindOp & " '" & gsFindExpr & "'" Else sTmp = AddBrackets((mrecFormRecordset(i).Name)) + gsFindOp + gsFindExpr End If Select Case gnFindType Case 0 mrecFormRecordset.FindFirst sTmp Case 1 mrecFormRecordset.FindNext sTmp Case 2 mrecFormRecordset.FindPrevious sTmp Case 3 mrecFormRecordset.FindLast sTmp End Select mbNotFound = mrecFormRecordset.NoMatch AfterWhile: Screen.MousePointer = vbDefault If gbFindFailed = True Then 'go back to original row mrecFormRecordset.Bookmark = sBookMark ElseIf mbNotFound Then Beep MsgBox "Record Not Found", 48 mrecFormRecordset.Bookmark = sBookMark GoTo FindStart Else sBookMark = mrecFormRecordset.Bookmark 'save the new position 'now we need to reposition the scrollbar to reflect the move If mlNumRows > 99 Then hsclCurrRow.VALUE = (mrecFormRecordset.PercentPosition * mlNumRows) / 100 + 1 Else hsclCurrRow.VALUE = mrecFormRecordset.PercentPosition End If mrecFormRecordset.Bookmark = sBookMark End If DisplayCurrentRecord Me, mrecFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False MsgBar gsNULL_STR, False Exit Sub FindErr: Screen.MousePointer = vbDefault If Err <> gnEOF_ERR Then ShowError Exit Sub Else mbNotFound = True Resume Next End If End Sub Private Sub Form_Load() Dim nStartPt As Integer 'starting point of table name Dim nEndPt As Integer 'ending point of table name Dim sTmp As String 'temp recordset name string Dim sWhere As String 'where clause Dim nFieldType As Integer 'field type of current field Dim i As Integer, j As Integer 'indexes Dim qdfTmp As QueryDef Dim bParmQry As Integer Dim prpTmp As Property 'user defined property object Dim Start1 As Long, Finish1 As Long, Start2 As Long, Finish2 As Long On Error GoTo DynasetErr SetHourglass 'set the message bar If frmMDI.optDynaset.VALUE = True Then MsgBar "Opening Dynaset", True ElseIf frmMDI.optSnapshot.VALUE = True Then MsgBar "Opening Snapshot", True ElseIf frmMDI.optPassThru.VALUE = True Then MsgBar "Opening PassThru Snapshot", True Else 'must be set to table so we need to change it 'because this form only handles dynasets and snapshots frmMDI.optDynaset.VALUE = True MsgBar "Opening Dynaset", True End If 'assign the temp string with the select statement 'if it is not empty, otherwise, use the table list name If gbFromSQL = True Then If Len(gsDynaString) = 0 Then sTmp = frmSQL.txtSQLStatement Else sTmp = gsDynaString End If Set qdfTmp = gdbCurrentDB.CreateQueryDef(gsNULL_STR, sTmp) If qdfTmp.PARAMETERS.Count > 0 Then bParmQry = True End If ElseIf Len(gsTableDynaFilter) > 0 Then sTmp = gsTableDynaFilter Else If frmTables.optTables.VALUE = True Then sTmp = StripConnect(frmTables.lstTables.TEXT) Else sTmp = frmTables.lstQueryDefs.TEXT Set qdfTmp = gdbCurrentDB.QueryDefs(frmTables.lstQueryDefs.TEXT) If qdfTmp.PARAMETERS.Count > 0 Then bParmQry = True End If End If End If 'attemp to open the recordset If bParmQry = True Then 'parameterized query SetParams qdfTmp Start1 = OSTimeGetTime() Set mrecFormRecordset = qdfTmp.OpenRecordset( _ IIf(frmMDI.optDynaset.VALUE = True, 2, 4) _ , IIf(frmMDI.optPassThru.VALUE = True, dbSQLPassThrough, 0)) Else Start1 = OSTimeGetTime() If gbFromSQL = True Then If frmMDI.optPassThru.VALUE = True Then 'need to open a temp querydef so that 'the PercentPosition prop will be available 'on the passthrough recordset Set qdfTmp = gdbCurrentDB.CreateQueryDef(gsNULL_STR, sTmp) 'need to set the connect property so a passthorugh querydef is created qdfTmp.Connect = gdbCurrentDB.Connect Set mrecFormRecordset = qdfTmp.OpenRecordset(dbOpenSnapshot) Else If frmMDI.optDynaset.VALUE = True Then Set mrecFormRecordset = gdbCurrentDB.OpenRecordset(sTmp, dbOpenDynaset) Else Set mrecFormRecordset = gdbCurrentDB.OpenRecordset(sTmp, dbOpenSnapshot) End If End If Else If frmMDI.optPassThru.VALUE = True Then sTmp = "select * from " & StripOwner(sTmp) 'need to open a temp querydef so that 'the PercentPosition prop will be available 'on the passthrough recordset Set qdfTmp = gdbCurrentDB.CreateQueryDef(gsNULL_STR, sTmp) Set mrecFormRecordset = qdfTmp.OpenRecordset(dbOpenSnapshot, dbSQLPassThrough) Else If frmMDI.optDynaset.VALUE = True Then Set mrecFormRecordset = gdbCurrentDB.OpenRecordset(sTmp, dbOpenDynaset) Else Set mrecFormRecordset = gdbCurrentDB.OpenRecordset(sTmp, dbOpenSnapshot) End If End If End If End If Finish1 = OSTimeGetTime() 'set the locking type If gsDataType = gsJETMDB And mrecFormRecordset.Type <> dbOpenSnapshot Then mrecFormRecordset.LockEdits = gnMULocking End If 'parse off table name to store in msTblName sWhere = gsNULL_STR nStartPt = InStr(1, UCase(sTmp), "FROM") If nStartPt > 0 Then 'must be a "select from" statement nStartPt = nStartPt + 5 For nEndPt = nStartPt To Len(sTmp) 'search for a nStartPtace or the end of sTmp If Mid(sTmp, nEndPt, 1) = " " Or Mid(sTmp, nEndPt, 1) = Chr(13) Then 'get where clause if there is one sWhere = Mid(sTmp, nStartPt, Len(sTmp) - nStartPt + 1) Exit For End If Next msTableName = Mid(sTmp, nStartPt, nEndPt - nStartPt) If Len(sWhere) = 0 Then sWhere = msTableName Else 'must be a table name only msTableName = sTmp sWhere = msTableName End If 'get the row count Start2 = OSTimeGetTime() mlNumRows = GetNumbRecs(mrecFormRecordset) 'query numb of recs Finish2 = OSTimeGetTime() SetScrollBar 'load the controls on the recordset form lblFieldName(0).Visible = True txtFieldData(0).Visible = True nFieldType = mrecFormRecordset(0).Type txtFieldData(0).Width = GetFieldWidth(nFieldType) If nFieldType = dbText Then txtFieldData(0).MaxLength = mrecFormRecordset(0).Size txtFieldData(0).TabIndex = 0 For i = 1 To mrecFormRecordset.Fields.Count - 1 picFields.Height = picFields.Height + gnCTLARRAYHEIGHT Load lblFieldName(i) lblFieldName(i).TOP = lblFieldName(i - 1).TOP + gnCTLARRAYHEIGHT lblFieldName(i).Visible = True Load txtFieldData(i) txtFieldData(i).TOP = txtFieldData(i - 1).TOP + gnCTLARRAYHEIGHT txtFieldData(i).Visible = True nFieldType = mrecFormRecordset.Fields(i).Type txtFieldData(i).Width = GetFieldWidth(nFieldType) If nFieldType = dbText Then txtFieldData(i).MaxLength = mrecFormRecordset(i).Size txtFieldData(i).TabIndex = i Next 'resize main window Me.Width = 5520 If i <= 10 Then Me.Height = ((i + 1) * gnCTLARRAYHEIGHT) + 1600 Else Me.Height = 4368 Me.Width = Me.Width + 260 vsbScrollBar.Visible = True vsbScrollBar.MIN = 1080 vsbScrollBar.MAX = 1080 - (i * gnCTLARRAYHEIGHT) + 2240 End If 'display the field names For i = 0 To mrecFormRecordset.Fields.Count - 1 lblFieldName(i).Caption = mrecFormRecordset(i).Name & ":" Next DisplayCurrentRecord Me, mrecFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False If mrecFormRecordset.Type = dbOpenDynaset Then If Len(gsTableDynaFilter) > 0 Then Me.Caption = "Filtered Dynaset: " & msTableName Else Me.Caption = "Dynaset: " & msTableName End If Else If Len(gsTableDynaFilter) > 0 Then Me.Caption = "Filtered Snapshot: " & msTableName ElseIf frmMDI.optPassThru.VALUE = True Then Me.Caption = "PassThru Snapshot: " & msTableName Else Me.Caption = "Snapshot: " & msTableName End If End If Me.Left = 1000 Me.TOP = 1000 If frmMDI.mnuPShowPerf.Checked = True Then Me.Show MsgBox CStr(mlNumRows) & " rows found in " & (Finish1 - Start1) / 1000 & " seconds!" & gsNewLine & (Finish2 - Start2) / 1000 & " seconds to Get Record Count!", 48 End If Screen.MousePointer = vbDefault MsgBar gsNULL_STR, False Exit Sub DynasetErr: ShowError Unload Me Exit Sub End Sub Private Sub Form_Resize() On Error Resume Next Dim nHeight As Integer Dim i As Integer Dim nTotWidth As Integer Const nHeightFactor = 1420 If WindowState <> 1 Then 'not minimized MsgBar "Resizing Form", True 'make sure the form is lined up on a field nHeight = Height If (nHeight - nHeightFactor) Mod gnCTLARRAYHEIGHT <> 0 Then Me.Height = ((nHeight - nHeightFactor) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + nHeightFactor End If 'resize the status bar picMoveButtons.TOP = Me.Height - 650 'resize the scrollbar vsbScrollBar.Height = picMoveButtons.TOP - (picViewButtons.TOP - picFldHdr.Height) - 1320 vsbScrollBar.Left = Me.Width - 360 If mrecFormRecordset.Fields.Count > 10 Then picFields.Width = Me.Width - 260 nTotWidth = vsbScrollBar.Left - 20 Else picFields.Width = Me.Width - 20 nTotWidth = Me.Width - 50 End If picFldHdr.Width = Me.Width - 20 'widen the fields if possible For i = 0 To mrecFormRecordset.Fields.Count - 1 lblFieldName(i).Width = 0.3 * nTotWidth txtFieldData(i).Left = lblFieldName(i).Width + 20 If mrecFormRecordset(i).Type = dbText Or mrecFormRecordset(i).Type = dbMemo Then txtFieldData(i).Width = 0.7 * nTotWidth - 250 End If Next lblFieldValue.Left = txtFieldData(0).Left hsclCurrRow.Width = picMoveButtons.Width \ 2 lblStatus.Width = picMoveButtons.Width \ 2 lblStatus.Left = hsclCurrRow.Width + 10 End If MsgBar gsNULL_STR, False End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next Unload mfrmFind 'get rid of attached find form mrecFormRecordset.Close 'close the form recordset DBEngine.Idle dbFreeLocks MsgBar gsNULL_STR, False End Sub Private Sub cmdProperties_Click() ShowProperties "Recordset", mrecFormRecordset End Sub Private Sub cmdSort_Click() On Error GoTo SortErr Dim sBookMark As String Dim recRecordset1 As Recordset, recRecordset2 As Recordset Dim SortStr As String sBookMark = mrecFormRecordset.Bookmark 'save the bookmark Set recRecordset1 = mrecFormRecordset 'save the recordset SortStr = InputBox("Enter Sort Column:") If Len(SortStr) = 0 Then Exit Sub SetHourglass MsgBar "Setting New Sort Order", True mrecFormRecordset.Sort = SortStr 'establish the Sort Set recRecordset2 = mrecFormRecordset.OpenRecordset(mrecFormRecordset.Type) Set mrecFormRecordset = recRecordset2 'assign back to original recordset object 'everything must be okay so redisplay form on 1st record mlNumRows = GetNumbRecs(mrecFormRecordset) 'query numb of recs hsclCurrRow.VALUE = 0 DisplayCurrentRecord Me, mrecFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False Screen.MousePointer = vbDefault MsgBar gsNULL_STR, False Exit Sub SortErr: ShowError Set mrecFormRecordset = recRecordset1 're-assign back to original mrecFormRecordset.Bookmark = sBookMark 'go back to original record Exit Sub End Sub Private Sub cmdUpdate_Click() On Error GoTo UpdateErr Dim nDelay As Long Dim nRetryCnt As Integer SetHourglass RetryUpd: mrecFormRecordset.UPDATE If gbTransPending Then gbDBChanged = True If mbAddNewFlag = True Then mlNumRows = mlNumRows + 1 SetScrollBar 'move to the new record mrecFormRecordset.Bookmark = mrecFormRecordset.LastModified End If picChangeButtons.Visible = False picViewButtons.Visible = True hsclCurrRow.Enabled = True mbEditFlag = False mbAddNewFlag = False DisplayCurrentRecord Me, mrecFormRecordset, mlNumRows, mbAddNewFlag mbDataChanged = False DBEngine.Idle dbFreeLocks Screen.MousePointer = vbDefault Exit Sub UpdateErr: 'check for locked error If Err = 3260 And nRetryCnt < gnMURetryCnt Then nRetryCnt = nRetryCnt + 1 mrecFormRecordset.Bookmark = mrecFormRecordset.Bookmark 'Cancel the update DBEngine.Idle dbFreeLocks nDelay = Timer 'Wait gnMUDelay seconds While Timer - nDelay < gnMUDelay 'do nothing Wend Resume RetryUpd Else ShowError Exit Sub End If End Sub Private Sub SetScrollBar() If mlNumRows < 2 Then hsclCurrRow.MAX = 100 hsclCurrRow.SmallChange = 100 hsclCurrRow.LargeChange = 100 ElseIf mlNumRows > 32767 Then hsclCurrRow.MAX = 32767 hsclCurrRow.SmallChange = 1 hsclCurrRow.LargeChange = 1000 ElseIf mlNumRows > 99 Then hsclCurrRow.MAX = mlNumRows hsclCurrRow.SmallChange = 1 hsclCurrRow.LargeChange = mlNumRows \ 20 Else 'must be between 2 and 100 hsclCurrRow.MAX = 100 hsclCurrRow.SmallChange = 100 \ (mlNumRows - 1) hsclCurrRow.LargeChange = (100 \ (mlNumRows - 1)) * 10 End If End Sub