Компонент для работы с данными - Базы данных - Интересные решения для программистов - Примеры кода

Базы данных → Компонент для работы с данными → Visual Basic

Компонент для работы с данными (в исходном виде), и пример его использования.

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

ado, data, database, vb, visual basic

KOS_MOS

Алексей

19.10.2008

Меню

Подписка на RSS:

Подпишись на RSS-ленту

Поиск

Облако тегов

	Базы данных → Компонент для работы с данными → Visual Basic Компонент для работы с данными (в исходном виде), и пример его использования. 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 ado, data, database, vb, visual basic KOS_MOS Алексей 19.10.2008 Ваше имя Ваш E-mail (если хотите отслеживать комментарии) Дoкажи, что ты не робот Текст комментария	Меню CodeIgniter Алгоритмы Базы данных Дата и Время Интернет Интерфейс Мультимедиа ОС и Железо Работа с текстом Разное Технологии Файлы Подписка на RSS: Подпишись на RSS-ленту Поиск Облако тегов .net array asp bash browser charset check class clean convert count create css curl database date delete directory download element email equivalent extension file find form format function get height html http ie image javascript jquery load mysql number page perl php random scriplet send shell size sql string text time url utf8 variable vb visual basic width window xml xslt