Master 95 #1

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

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

Wrap

Visual Basic Form | 1995-07-26 | 24.4 KB | 779 lines

VERSION 4.00 Begin VB.Form frmTableObj ClientHeight = 3495 ClientLeft = 1335 ClientTop = 2625 ClientWidth = 5685 Height = 3900 HelpContextID = 2016145 Icon = "TABLEOBJ.frx":0000 KeyPreview = -1 'True Left = 1275 LinkTopic = "Form1" LockControls = -1 'True MDIChild = -1 'True ScaleHeight = 3480 ScaleMode = 0 'User ScaleWidth = 5705.42 Tag = "Recordset" Top = 2280 Width = 5805 Begin VB.PictureBox picViewButtons Align = 1 'Align Top Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 705 Left = 0 ScaleHeight = 705 ScaleMode = 0 'User ScaleWidth = 5688.392 TabIndex = 1 TabStop = 0 'False Top = 0 Width = 5685 Begin VB.ComboBox cboIndexes BackColor = &H00FFFFFF& Height = 300 Left = 720 Style = 2 'Dropdown List TabIndex = 9 Top = 360 Width = 4335 End Begin VB.CommandButton cmdSeek Caption = "&Seek" Height = 330 Left = 2280 TabIndex = 5 Top = 0 Width = 750 End Begin VB.CommandButton cmdFilter Caption = "F&ilter" Height = 330 Left = 3000 TabIndex = 6 Top = 0 Width = 750 End Begin VB.CommandButton cmdClose Cancel = -1 'True Caption = "&Close" Height = 330 Left = 4425 TabIndex = 8 TabStop = 0 'False Top = 0 Width = 750 End Begin VB.CommandButton cmdProp Caption = "&Prop" Height = 330 Left = 3720 TabIndex = 7 Top = 0 Width = 750 End Begin VB.CommandButton cmdDelete Caption = "&Delete" Height = 330 Left = 1560 TabIndex = 4 Top = 0 Width = 750 End Begin VB.CommandButton cmdEdit Caption = "&Edit" Height = 330 Left = 840 TabIndex = 3 Top = 0 Width = 750 End Begin VB.CommandButton cmdAdd Caption = "&Add" Height = 330 Left = 0 TabIndex = 2 Top = 0 Width = 870 End Begin VB.Label lblIndex Caption = "Index:" Height = 255 Left = 120 TabIndex = 25 Top = 400 Width = 615 End End Begin VB.PictureBox picFieldHeader Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 240 Left = 0 ScaleHeight = 240 ScaleMode = 0 'User ScaleWidth = 14948.92 TabIndex = 22 Top = 705 Width = 14946 Begin VB.Label lblFieldValue Caption = " Value (F4=Zoom) " Height = 255 Left = 1680 TabIndex = 24 Top = 0 Width = 3165 End Begin VB.Label lblFieldHdr Caption = "Field Name:" Height = 252 Left = 120 TabIndex = 23 Top = 0 Width = 1212 End End Begin VB.PictureBox picChangeButtons BorderStyle = 0 'None Height = 690 Left = 0 ScaleHeight = 690 ScaleMode = 0 'User ScaleWidth = 5658.375 TabIndex = 14 TabStop = 0 'False Top = 0 Visible = 0 'False Width = 5655 Begin VB.CommandButton cmdUpdate Caption = "&Update" Height = 372 Left = 960 TabIndex = 16 Top = 48 Width = 1212 End Begin VB.CommandButton cmdCancel Caption = "&Cancel" Height = 372 Left = 2640 TabIndex = 15 Top = 48 Width = 1212 End End Begin VB.PictureBox picStatBox Align = 2 'Align Bottom Appearance = 0 'Flat BorderStyle = 0 'None ForeColor = &H80000008& Height = 285 Left = 0 ScaleHeight = 298.153 ScaleMode = 0 'User ScaleWidth = 5695.241 TabIndex = 20 TabStop = 0 'False Top = 3210 Width = 5685 Begin VB.CommandButton cmdNext Caption = ">" Height = 287 Left = 4200 TabIndex = 12 Top = 0 Width = 375 End Begin VB.CommandButton cmdLast Caption = ">|" Height = 287 Left = 4575 TabIndex = 13 Top = 0 Width = 375 End Begin VB.CommandButton cmdFirst Caption = "|<" Height = 287 Left = 0 TabIndex = 10 Top = 0 Width = 375 End Begin VB.CommandButton cmdPrevious Caption = "<" Height = 287 Left = 375 TabIndex = 11 Top = 0 Width = 375 End Begin VB.Label lblStatus BackColor = &H00FFFFFF& BorderStyle = 1 'Fixed Single Height = 285 Left = 735 TabIndex = 21 Top = 0 Width = 3360 End End Begin VB.VScrollBar vsbScrollBar Height = 2616 LargeChange = 3000 Left = 5040 SmallChange = 300 TabIndex = 19 Top = 960 Visible = 0 'False Width = 252 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 = 17 TabStop = 0 'False Top = 960 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 Height = 252 Index = 0 Left = 0 TabIndex = 18 Top = 60 Visible = 0 'False Width = 1572 End End Attribute VB_Name = "frmTableObj" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit 'form variables Dim mrecFormTable As Recordset 'current form's table Dim msTableName As String 'form recordset table name Dim msBookMark As String 'form bookmark Dim mbEditFlag As Integer 'edit mode Dim mbAddNewFlag As Integer 'add mode Dim mbDataChanged As Integer Dim mfrmSeek As New frmSeek 'seek form instance Dim mlNumRows As Long 'total rows in Table Private Sub cmdAdd_Click() On Error GoTo AddErr 'set the mode mrecFormTable.AddNew lblStatus.Caption = "Add record" mbAddNewFlag = True If mrecFormTable.RecordCount > 0 Then msBookMark = mrecFormTable.Bookmark Else msBookMark = gsNULL_STR End If picChangeButtons.Visible = True picViewButtons.Visible = False cmdNext.Enabled = False cmdFirst.Enabled = False cmdLast.Enabled = False cmdPrevious.Enabled = False ClearDataFields Me, mrecFormTable.Fields.Count txtFieldData(0).SetFocus Exit Sub AddErr: ShowError Exit Sub End Sub Private Sub cmdCancel_Click() On Error Resume Next picChangeButtons.Visible = False picViewButtons.Visible = True cmdNext.Enabled = True cmdFirst.Enabled = True cmdLast.Enabled = True cmdPrevious.Enabled = True mbEditFlag = False mbAddNewFlag = False If Len(msBookMark) > 0 Then mrecFormTable.Bookmark = msBookMark DisplayCurrentRecord Me, mrecFormTable, mlNumRows, mbAddNewFlag mbDataChanged = False DBEngine.Idle dbFreeLocks 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 mrecFormTable(Index) = txtFieldData(Index) End If 'reset for valid or error condition mbDataChanged = False Exit Sub FldDataErr: ShowError mbDataChanged = False Exit Sub End Sub Private Sub lblFieldName_DblClick(Index As Integer) On Error GoTo ZoomErr If mrecFormTable(Index).Type = dbText Or mrecFormTable(Index).Type = dbMemo Then If mrecFormTable(Index).Type = dbText Then gsZoomData = txtFieldData(Index).Text ElseIf mrecFormTable(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(mrecFormTable(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) frmZoom.Top = Top + 1200 frmZoom.Left = Left + 250 If mbAddNewFlag Or mbEditFlag Then frmZoom.cmdSave.Visible = True frmZoom.cmdCloseNoSave.Visible = True Else frmZoom.cmdClose.Visible = True End If If mrecFormTable(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 mrecFormTable(Index).Type = dbText And Len(gsZoomData) > mrecFormTable(Index).Size Then Beep MsgBox "Field Length Exceeded, Data Truncated!", 48 txtFieldData(Index).Text = Mid(gsZoomData, 1, mrecFormTable(Index).Size) Else txtFieldData(Index).Text = gsZoomData End If mrecFormTable(Index) = txtFieldData(Index).Text mbDataChanged = False End If End If Exit Sub ZoomErr: ShowError Exit Sub End Sub Private Sub cboIndexes_Click() On Error GoTo IndErr If mrecFormTable Is Nothing Then Exit Sub If mrecFormTable.Index = Mid(cboIndexes.Text, 1, InStr(1, cboIndexes.Text, ":") - 1) Then Exit Sub mrecFormTable.Index = Mid(cboIndexes.Text, 1, InStr(1, cboIndexes.Text, ":") - 1) DisplayCurrentRecord Me, mrecFormTable, mlNumRows, mbAddNewFlag mbDataChanged = False Exit Sub IndErr: ShowError Exit Sub End Sub Private Sub cmdClose_Click() Unload Me End Sub Private Sub vsbScrollBar_Change() Dim nTop As Integer nTop = vsbScrollBar If (nTop - 960) Mod gnCTLARRAYHEIGHT = 0 Then picFields.Top = nTop Else picFields.Top = ((nTop - 960) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + 960 End If End Sub Private Sub cmdDelete_Click() On Error GoTo DelRecErr If MsgBox("Delete Current Record?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then mrecFormTable.Delete If gbTransPending Then gbDBChanged = True If mrecFormTable.EOF = False Then mrecFormTable.MoveNext End If mlNumRows = mlNumRows - 1 DisplayCurrentRecord Me, mrecFormTable, 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: mrecFormTable.Edit lblStatus.Caption = "Edit record" mbEditFlag = True txtFieldData(0).SetFocus msBookMark = mrecFormTable.Bookmark picChangeButtons.Visible = True picViewButtons.Visible = False cmdNext.Enabled = False cmdFirst.Enabled = False cmdLast.Enabled = False cmdPrevious.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 sFilter As String Dim frmDyn As New frmDynaSnap sFilter = InputBox("Enter Filter Expression:") If Len(sFilter) = 0 Then Exit Sub gsTableDynaFilter = "select * from " & AddBrackets(msTableName) & " where " & sFilter frmDyn.Show 'open recordset form w/ filtered table gsTableDynaFilter = gsNULL_STR Exit Sub FilterErr: ShowError Exit Sub End Sub Private Sub cmdFirst_Click() On Error GoTo GoFirstError mrecFormTable.MoveFirst DisplayCurrentRecord Me, mrecFormTable, mlNumRows, mbAddNewFlag mbDataChanged = False Screen.MousePointer = vbDefault MsgBar gsNULL_STR, False Exit Sub GoFirstError: ShowError Exit Sub End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If mbEditFlag = True Or mbAddNewFlag = True Then Exit Sub Select Case KeyCode Case 35 'end Call cmdLast_Click Case 36 'home Call cmdFirst_Click Case 38 'up arrow If Shift = 2 Then Call cmdFirst_Click Else Call cmdPrevious_Click End If Case 40 'down arrow If Shift = 2 Then Call cmdLast_Click Else Call cmdNext_Click End If End Select End Sub Private Sub Form_Load() Dim nFieldType As Integer Dim i As Integer Dim tdf As TableDef Dim idx As Index Dim sIndex As String On Error GoTo TableErr SetHourglass MsgBar "Opening Table", True msTableName = StripConnect(frmTables.lstTables.Text) Set tdf = gdbCurrentDB.TableDefs(msTableName) For Each idx In tdf.Indexes sIndex = idx.Name sIndex = sIndex & ":" & idx.Fields If idx.UNIQUE = True Then sIndex = sIndex & ":Unique" Else sIndex = sIndex & ":Non-Unique" End If If idx.PRIMARY = True Then sIndex = sIndex & ":Primary" End If cboIndexes.AddItem sIndex Next Set mrecFormTable = gdbCurrentDB.OpenRecordset(msTableName, dbOpenTable) 'set the locking type If gsDataType = gsJETMDB Then mrecFormTable.LockEdits = gnMULocking End If 'show the first record mlNumRows = GetNumbRecs(mrecFormTable) 'load the controls on the Table form lblFieldName(0).Visible = True txtFieldData(0).Visible = True nFieldType = mrecFormTable.Fields(0).Type txtFieldData(0).Width = GetFieldWidth(nFieldType) txtFieldData(0).TabIndex = 0 If nFieldType = dbText Then txtFieldData(0).MaxLength = mrecFormTable.Fields(0).Size For i = 1 To mrecFormTable.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 = mrecFormTable.Fields(i).Type txtFieldData(i).Width = GetFieldWidth(nFieldType) txtFieldData(i).TabIndex = i If nFieldType = dbText Then txtFieldData(i).MaxLength = mrecFormTable(i).Size Next 'resize main window If i <= 10 Then Me.Height = ((i + 1) * gnCTLARRAYHEIGHT) + 1600 Else Me.Height = 4668 Me.Width = Me.Width + 260 vsbScrollBar.Visible = True vsbScrollBar.Min = 900 vsbScrollBar.Max = 900 - (i * gnCTLARRAYHEIGHT&) + 2500 End If 'display the field names For i = 0 To mrecFormTable.Fields.Count - 1 lblFieldName(i).Caption = mrecFormTable(i).Name & ":" Next If cboIndexes.ListCount > 0 Then cboIndexes.ListIndex = 0 Else DisplayCurrentRecord Me, mrecFormTable, mlNumRows, mbAddNewFlag mbDataChanged = False End If Me.Caption = "Table: " & msTableName Me.Width = 5805 Me.Left = 1000 Me.Top = 1000 Screen.MousePointer = vbDefault MsgBar gsNULL_STR, False Exit Sub TableErr: 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 If WindowState <> 1 Then 'not minimized MsgBar "Resizing Form", True 'make sure the form is lined up on a field nHeight = Me.Height If (nHeight - 1660) Mod gnCTLARRAYHEIGHT <> 0 Then Me.Height = ((nHeight - 1660) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + 1660 End If 'resize the status bar picStatBox.Top = Me.Height - 650 'resize the scrollbar vsbScrollBar.Height = picStatBox.Top - (picViewButtons.Top - picFieldHeader.Height) - 1200 vsbScrollBar.Left = Me.Width - 360 If mrecFormTable.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 picFieldHeader.Width = Me.Width - 20 'widen the fields if possible For i = 0 To mrecFormTable.Fields.Count - 1 lblFieldName(i).Width = 0.3 * nTotWidth txtFieldData(i).Left = lblFieldName(i).Width + 20 If mrecFormTable(i).Type = dbText Or mrecFormTable(i).Type = dbMemo Then txtFieldData(i).Width = 0.7 * nTotWidth - 250 End If Next lblFieldValue.Left = txtFieldData(0).Left lblStatus.Width = Me.Width - 1600 cmdNext.Left = lblStatus.Width + 745 cmdLast.Left = cmdNext.Left + 370 End If MsgBar gsNULL_STR, False End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next Unload mfrmSeek 'get rid of attached seek form mrecFormTable.Close 'close the form Table DBEngine.Idle dbFreeLocks MsgBar gsNULL_STR, False End Sub Private Sub cmdLast_Click() On Error GoTo GoLastError mrecFormTable.MoveLast 'show the current record DisplayCurrentRecord Me, mrecFormTable, mlNumRows, mbAddNewFlag mbDataChanged = False Exit Sub GoLastError: ShowError Exit Sub End Sub Private Sub cmdNext_Click() On Error GoTo GoNextError mrecFormTable.MoveNext 'show the current record DisplayCurrentRecord Me, mrecFormTable, mlNumRows, mbAddNewFlag mbDataChanged = False Exit Sub GoNextError: ShowError Exit Sub End Sub Private Sub cmdPrevious_Click() On Error GoTo GoPrevError mrecFormTable.MovePrevious 'show the current record DisplayCurrentRecord Me, mrecFormTable, mlNumRows, mbAddNewFlag mbDataChanged = False Exit Sub GoPrevError: ShowError Exit Sub End Sub Private Sub cmdProp_Click() ShowProperties "Table", mrecFormTable End Sub Private Sub cmdSeek_Click() On Error GoTo SeekErr Dim sBookMark As String If mrecFormTable.RecordCount = 0 Then Exit Sub SeekStart: MsgBar "Enter Seek Parameters", False frmSeek.Show vbModal If Len(gsSeekValue) = 0 Then MsgBar gsNULL_STR, False Exit Sub End If sBookMark = mrecFormTable.Bookmark SetHourglass mrecFormTable.Seek gsSeekOperator, gsSeekValue Screen.MousePointer = vbDefault 'return to old record if no match was found If mrecFormTable.NoMatch And Len(sBookMark) > 0 Then Beep MsgBox "Record Not Found", 48 mrecFormTable.Bookmark = sBookMark GoTo SeekStart End If DisplayCurrentRecord Me, mrecFormTable, mlNumRows, mbAddNewFlag mbDataChanged = False MsgBar gsNULL_STR, False Exit Sub SeekErr: Screen.MousePointer = vbDefault MsgBox Error Exit Sub 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", mrecFormTable.Fields(Index) End Sub Private Sub cmdUpdate_Click() On Error GoTo UpdateErr Dim nDelay As Long Dim nRetryCnt As Integer SetHourglass RetryUpd: mrecFormTable.Update If gbTransPending Then gbDBChanged = True If mbAddNewFlag = True Then mlNumRows = mlNumRows + 1 mrecFormTable.MoveLast 'move to the new record End If mbEditFlag = False mbAddNewFlag = False picChangeButtons.Visible = False picViewButtons.Visible = True cmdNext.Enabled = True cmdFirst.Enabled = True cmdLast.Enabled = True cmdPrevious.Enabled = True DisplayCurrentRecord Me, mrecFormTable, mlNumRows, mbAddNewFlag mbDataChanged = False DBEngine.Idle dbFreeLocks Screen.MousePointer = vbDefault Exit Sub UpdateErr: If Err = 3260 And nRetryCnt < gnMURetryCnt Then nRetryCnt = nRetryCnt + 1 mrecFormTable.Bookmark = mrecFormTable.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