Компонент для работы с данными (в исходном виде), и пример его использования.
Код
Option Explicit
#If False Then
' Just to Maintain Case
Private adoMoveFirst
Private adoStayBOF
Private adoMoveLast
Private adoStayEOF
Private adoNEW
Private adoADD
Private adoDEL
Private adoBOF
Private adoBOFX
Private adoPREV
Private adoREFRESH
Private adoNEXT
Private adoEOFX
Private adoEOF
Private adoSAVE
Private adoUNDO
Private adoCOUNT
#End If
Private Enum ADOButtons
adoNEW
adoDEL
adoBOF
adoBOFX
adoPREV
adoREFRESH
adoNEXT
adoEOFX
adoEOF
adoSAVE
adoUNDO
adoCOUNT
End Enum
' Control Properties
Private mDelayDelete As Boolean
Private mBackColor As OLE_COLOR
Private mForeColor As OLE_COLOR
Private mBOFAction As DataBOFconstants
Private mEOFAction As DataEOFConstants
Private mBookMark As Variant
' Private Variables
Private mBusy As Boolean
Private mAdding As Boolean
Private mIsDirty As Boolean
Private mToolTips As Variant
' Control Events
Public Event AddNew(Cancel As Boolean)
Public Event Changed(Action As ADODB.EventReasonEnum)
Public Event Delete(Cancel As Boolean)
Public Event Save(Cancel As Boolean)
Public Event Undo(Cancel As Boolean)
' RecordSet Events
Private WithEvents Recordset As ADODB.Recordset
' Read / Write Properties
Public Property Let BackColor(vdata As OLE_COLOR)
mBackColor = vdata
UserControl.BackColor = mBackColor
PropertyChanged "BackColor"
End Property
Public Property Get BackColor() As OLE_COLOR
BackColor = mBackColor
End Property
Public Property Let DelayDelete(vdata As Boolean)
mDelayDelete = vdata
PropertyChanged "DelayDelete"
End Property
Public Property Get DelayDelete() As Boolean
DelayDelete = mDelayDelete
End Property
Public Property Let ForeColor(vdata As OLE_COLOR)
mForeColor = vdata
UserControl.ForeColor = mForeColor
PropertyChanged "ForeColor"
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = mForeColor
End Property
' ADO Data Properties
' Read Only Properties
Public Property Get Connection() As ADODB.Connection
If Recordset Is Nothing Then Exit Property
Set Connection = Recordset.ActiveConnection
End Property
Public Property Let BOFAction(ByVal New_BOFAction As DataBOFconstants)
mBOFAction = New_BOFAction
PropertyChanged "BOFAction"
End Property
Public Property Get BOFAction() As DataBOFconstants
BOFAction = mBOFAction
End Property
Public Property Let EOFAction(ByVal New_EOFAction As DataEOFConstants)
mEOFAction = New_EOFAction
PropertyChanged "EOF Action"
End Property
Public Property Get EOFAction() As DataEOFConstants
EOFAction = mEOFAction
End Property
Public Property Set DataSource(vdata As ADODB.Recordset)
Set Recordset = vdata
Enable
End Property
Public Property Get DataSource() As ADODB.Recordset
Set DataSource = Recordset
End Property
Public Function EmptyRS() As Boolean
On Error Resume Next
'Checks for an EMPTY RecordSet
EmptyRS = True
If Not Recordset Is Nothing Then
EmptyRS = ((Recordset.BOF = True) And (Recordset.EOF = True))
End If
End Function
Private Sub Enable()
If mBusy Then Exit Sub
Dim lHasData As Boolean
Dim lPos As Long
Dim lCount As Long
Dim lMidway As Long
lHasData = Not EmptyRS
If lHasData Then
On Error Resume Next
lPos = Recordset.AbsolutePosition
On Error GoTo 0
lCount = Recordset.RecordCount
End If
' Do Navigation First
With cmdNav(adoBOF)
.Enabled = lHasData
If .Enabled Then .Enabled = Recordset.Supports(adMovePrevious) And lPos > 1 And (Not mAdding Or mIsDirty)
End With
With cmdNav(adoBOFX)
.Enabled = lHasData
If .Enabled Then .Enabled = Recordset.Supports(adMovePrevious) And lPos > 2 And (Not mAdding Or mIsDirty)
End With
With cmdNav(adoPREV)
.Enabled = lHasData
If .Enabled Then .Enabled = Recordset.Supports(adMovePrevious) And lPos > 1 And (Not mAdding Or mIsDirty)
End With
With cmdNav(adoNEXT)
.Enabled = lHasData
If .Enabled Then .Enabled = lPos < lCount And (Not mAdding Or mIsDirty)
End With
With cmdNav(adoEOFX)
.Enabled = lHasData
If .Enabled Then .Enabled = lPos < lCount - 1 And (Not mAdding Or mIsDirty)
End With
With cmdNav(adoEOF)
.Enabled = lHasData
If .Enabled Then .Enabled = lPos < lCount And (Not mAdding Or mIsDirty)
End With
' Edit Controls
With cmdNav(adoREFRESH)
.Enabled = lHasData
If .Enabled Then
.Enabled = Recordset.Supports(adResync)
If .Enabled Then .Enabled = (Not mAdding And Not mIsDirty)
End If
End With
With cmdNav(adoNEW)
.Enabled = lHasData
If .Enabled Then
.Enabled = Recordset.Supports(adAddNew)
If .Enabled Then .Enabled = (Not mAdding And Not mIsDirty)
End If
End With
With cmdNav(adoDEL)
.Enabled = lHasData
If .Enabled Then
.Enabled = Recordset.Supports(adDelete)
If .Enabled Then .Enabled = (Not mAdding And Not mIsDirty)
End If
End With
With cmdNav(adoSAVE)
.Enabled = lHasData
If .Enabled Then
.Enabled = Recordset.Supports(adUpdate) Or Recordset.Supports(adUpdateBatch)
If .Enabled Then .Enabled = mIsDirty Or mAdding
End If
End With
With cmdNav(adoUNDO)
.Enabled = lHasData
If .Enabled Then .Enabled = Recordset.Supports(adUpdate) Or Recordset.Supports(adUpdateBatch)
If .Enabled Then .Enabled = mIsDirty Or mAdding
End With
txtPOS.Text = lPos & " / " & lCount
End Sub
'#
'# Button Events
'#
Private Sub cmdNAV_Click(Index As Integer)
If mBusy Then Exit Sub
Dim lCancel As Boolean
Dim lHasData As Boolean
Dim lPos As Long
Dim lCount As Long
Dim lMidway As Long
On Error GoTo LocalError
lHasData = Not EmptyRS
If lHasData Then
With Recordset
lPos = .AbsolutePosition
lCount = .RecordCount
Select Case Index
Case adoBOF
If .RecordCount > 0 Then
If .Supports(adMovePrevious) Then .MoveFirst
If Not .BOF And Not .EOF Then mBookMark = .Bookmark
End If
Case adoBOFX
' Move between Current and First
lMidway = (.AbsolutePosition \ 2) * -1
If .Supports(adMovePrevious) Then .Move lMidway
If Not .BOF And Not .EOF Then mBookMark = .Bookmark
Case adoPREV
If .BOF Then
Select Case mBOFAction
Case DataBOFconstants.vbMoveFirst
If .Supports(adMovePrevious) Then .MoveFirst
If Not .BOF And Not .EOF Then mBookMark = .Bookmark
Case DataBOFconstants.vbBOF: ' Do nothing
End Select
Else
If .Supports(adMovePrevious) Then .MovePrevious
If Not .BOF And Not .EOF Then mBookMark = .Bookmark
End If
Case adoNEXT
If .EOF Then
Select Case mEOFAction
Case DataEOFConstants.vbAddNew
If .Supports(adAddNew) Then
cmdNAV_Click adoNEW
Exit Sub
End If
Case DataEOFConstants.vbMoveLast
.MoveLast
If Not .BOF And Not .EOF Then mBookMark = .Bookmark
Case DataEOFConstants.vbEOF: ' Do nothing
End Select
Else
.MoveNext
If Not .BOF And Not .EOF Then mBookMark = .Bookmark
End If
Case adoEOFX
lMidway = (.RecordCount - .AbsolutePosition) \ 2
.Move lMidway
If .EOF Then .MoveLast ' should never happen
If Not .BOF And Not .EOF Then mBookMark = .Bookmark
Case adoEOF
.MoveLast
If Not .BOF And Not .EOF Then mBookMark = .Bookmark
Case adoREFRESH
If .Supports(adResync) Then .Requery
Case adoNEW
If .Supports(adAddNew) Then
RaiseEvent AddNew(lCancel)
If Not lCancel Then
mAdding = True
If Not .BOF And Not .EOF Then mBookMark = .Bookmark
.AddNew
End If
End If
Case adoUNDO
If .EditMode = adEditAdd Then
RaiseEvent Undo(lCancel)
If Not lCancel Then
mAdding = False
If .Supports(adUpdateBatch) Then
.CancelBatch adAffectAllChapters
ElseIf .Supports(adUpdate) Then
.CancelUpdate
End If
End If
End If
If mBookMark > 0 Then
.Bookmark = mBookMark
mBookMark = 0
End If
Case adoSAVE
' Check if the Record is Dirty
RaiseEvent Save(lCancel)
If Not lCancel Then
If .Supports(adUpdateBatch) Then
.UpdateBatch
ElseIf .Supports(adUpdate) Then
.Update
End If
End If
Case adoDEL
RaiseEvent Delete(lCancel)
If Not lCancel Then
If .Supports(adDelete) Then
.Delete
On Error Resume Next
If .LockType = adLockBatchOptimistic Then
.UpdateBatch
If Err.Number <> 0 Then .CancelBatch
ElseIf .LockType <> adLockReadOnly Then
.Update
If Err.Number <> 0 Then .CancelUpdate
End If
On Error GoTo 0
End If
cmdNAV_Click adoNEXT
Exit Sub
End If
End Select
End With
End If
Enable
Exit Sub
LocalError:
On Error Resume Next
Recordset.CancelUpdate
On Error GoTo 0
End Sub
'#
'# RecordSet Events
'#
Private Sub Recordset_EndOfRecordset(fMoreData As Boolean, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
'
End Sub
Private Sub Recordset_FetchComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
'
End Sub
Private Sub Recordset_FetchProgress(ByVal Progress As Long, ByVal MaxProgress As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
'
End Sub
Private Sub Recordset_FieldChangeComplete(ByVal cFields As Long, ByVal Fields As Variant, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
' After WillChangeField
End Sub
Private Sub Recordset_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
' After WillMove
RaiseEvent Changed(adReason)
mIsDirty = False
Enable
End Sub
Private Sub Recordset_RecordChangeComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
' After WillChangeRecord
Select Case adReason
Case adRsnAddNew, adRsnDelete, adRsnFirstChange
mIsDirty = True
End Select
Enable
End Sub
Private Sub Recordset_RecordsetChangeComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
' After WillChangeRecordset
End Sub
Private Sub RecordSet_WillChangeField(ByVal cFields As Long, ByVal Fields As Variant, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
' Before the Value property changes
mIsDirty = True
Enable
End Sub
Private Sub Recordset_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
Select Case adReason
Case adRsnAddNew
mAdding = True
mIsDirty = True
Case adRsnDelete, adRsnFirstChange
mIsDirty = True
mAdding = False
Case Else
mAdding = False
mIsDirty = False
End Select
Enable
End Sub
Private Sub Recordset_WillChangeRecordset(ByVal adReason As ADODB.EventReasonEnum, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
'On Recordset.Requery, Recordset.Resync, Recordset.Close, Recordset.Open, Recordset.Filter
End Sub
Private Sub Recordset_WillMove(ByVal adReason As ADODB.EventReasonEnum, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
' On Recordset.Open, Recordset.MoveNext, Recordset.Move, Recordset.MoveLast,
' Recordset.MoveFirst, Recordset.MovePrevious, Recordset.Bookmark, Recordset.AddNew,
' Recordset.Delete, Recordset.Requery, Recordset.Resync
If mIsDirty Or mAdding Then
If Recordset.Supports(adUpdateBatch) Then
Recordset.CancelBatch adAffectAllChapters
ElseIf Recordset.Supports(adUpdate) Then
Recordset.CancelUpdate
End If
mAdding = False
mIsDirty = False
End If
Enable
End Sub
'#
'# User Control Events
'#
Private Sub UserControl_GetDataMember(DataMember As String, Data As Object)
On Error GoTo LocalError
If Recordset Is Nothing Then
' make sure various properties have been set
' Disable all Functions
Else
Set Data = Recordset
End If
LocalError:
End Sub
Private Sub UserControl_Initialize()
Dim x As Integer
ReDim mToolTips(11)
mToolTips(adoNEW) = "Add a New Record"
mToolTips(adoDEL) = "Delete Record"
mToolTips(adoBOF) = "Move to First Record"
mToolTips(adoBOFX) = "Move miday between Current and First Record"
mToolTips(adoPREV) = "Move to Previous Record"
mToolTips(adoREFRESH) = "Refresh ALL Records"
mToolTips(adoNEXT) = "Move to Next Record"
mToolTips(adoEOFX) = "Move midway between Current and Last Record"
mToolTips(adoEOF) = "Move to Last Record"
mToolTips(adoSAVE) = "Save / Update the Current Record"
mToolTips(adoUNDO) = "Cancel all changes"
With UserControl
.Height = 360
.BackColor = vbButtonFace
.ForeColor = vbButtonText
End With
With cmdNav(0)
.Top = 0
.Left = 0
.ToolTipText = mToolTips(0)
.Width = UserControl.Height
.Height = .Width
End With
For x = 1 To 11
With cmdNav(x)
.Top = 0
If x < 11 Then
.ToolTipText = mToolTips(x)
.Left = cmdNav(0).Width * x
.Width = cmdNav(0).Width
End If
.Height = cmdNav(0).Height
End With
Next x
With txtPOS
.Enabled = True
.Locked = True
.Appearance = 1
.BorderStyle = vbBSSolid
.BackColor = vbBlack
.ForeColor = vbGreen
.Left = cmdNav(10).Left + cmdNav(10).Width + 50
.Top = 50
.Height = cmdNav(0).Height - 100
End With
With cmdNav(11)
.Top = 0
.Left = txtPOS.Left + txtPOS.Width
.Height = cmdNav(0).Height
End With
End Sub
Private Sub UserControl_InitProperties()
Set UserControl.Font = Ambient.Font
UserControl.BackColor = vbButtonFace
UserControl.ForeColor = vbButtonText
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
mBackColor = PropBag.ReadProperty("BackColor", vbButtonFace)
mDelayDelete = PropBag.ReadProperty("DelayDelete", True)
mForeColor = PropBag.ReadProperty("ForeColor", vbButtonText)
mBOFAction = PropBag.ReadProperty("BOFAction", DataBOFconstants.vbMoveFirst)
mEOFAction = PropBag.ReadProperty("EOFAction", DataEOFConstants.vbMoveLast)
Enable
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
'Write property values to storage
Call PropBag.WriteProperty("BackColor", mBackColor, vbButtonFace)
Call PropBag.WriteProperty("DelayDelete", mDelayDelete, True)
Call PropBag.WriteProperty("ForeColor", mForeColor, vbButtonText)
Call PropBag.WriteProperty("BOFAction", mBOFAction, DataBOFconstants.vbMoveFirst)
Call PropBag.WriteProperty("EOFAction", mEOFAction, DataEOFConstants.vbMoveLast)
End Sub
Private Sub UserControl_Resize()
On Error Resume Next
If UserControl.Height >= 360 Then UserControl.Height = 360
With cmdNav(11)
.Width = UserControl.ScaleWidth - (txtPOS.Left + txtPOS.Width)
End With
End Sub
Private Sub UserControl_Terminate()
On Error Resume Next
If Not Recordset Is Nothing Then
Recordset.Close
Set Recordset = Nothing
End If
Err.Clear
End Sub
Язык Visual Basic 6.0 является устаревшим. Многие примеры, размещенные на нашем сайте, были созданы еще во времена Windows 98 и могут не работать в современных операционных системах.
Если у вас возникнут какие-либо проблемы или вопросы, вы можете обратиться за помощью на наш форум.
Добавлять комментарии могут только зарегистрированные пользователи сайта.
Если у Вас уже есть учетная запись на Kbyte.Ru, пройдите процедуру авторизации.
Если Вы еще не зарегистрированы на Kbyte.Ru - зарегистрируйтесь.