TopPicLogo TopPicText

Прокрутка записей ленточной формы колесом мыши

По материалам: https://msdn.microsoft.com/en-us/library/office/ff191697.aspx

На событие "Колёсико мышки" формы вешакм код:

Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)
'es 13.03.2017 - http://msa.polarcom.ru
'Прокрутка записей ленточной формы колесом мыши
'--------------------------------------------------------------------
    On Error Resume Next
    Me.Recordset.Move Count
    Err.Clear
End Sub


Второй вариант
В любом модуле размещаем:

Public Sub MouseWhellInForm(Count As Long)
'es 26.07.2016 - http://msa.polarcom.ru
'Прокрутка записей ленточной формы колесом мыши
'--------------------------------------------------------------------
    On Error Resume Next
    If Count > 0 Then 'Обработка направления перехода
        DoCmd.GoToRecord , , acNext     ' Прокрутка ВНИЗ
    Else
        DoCmd.GoToRecord , , acPrevious ' Прокрутка ВВЕРХ
    End If
    Err.Clear
End Sub


В форме пишем:

Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)
    MouseWhellInForm Count 'Прокрутка записей ленточной формы колесом мыши
End Sub


Ещё вариант

По материалам: http://allenbrowne.com/ser-70.html

Public Function DoMouseWheel(frm As Form, lngCount As Long) As Integer
On Error GoTo Err_Handler
    'Purpose:   Make the MouseWheel scroll in Form View in Access 2007 and later.
    '           This code lets Access 2007 behave like older versions.
    'Return:    1 if moved forward a record, -1 if moved back a record, 0 if not moved.
    'Author:    Allen Browne, February 2007.
    'Usage:     In the MouseWheel event procedure of the form:
    '               Call DoMouseWheel(Me, Count)
    Dim strMsg As String
    'Run this only in Access 2007 and later, and only in Form view.
    If (Val(SysCmd(acSysCmdAccessVer)) >= 12#) And (frm.CurrentView = 1) And (lngCount <> 0&) Then
        'Save any edits before moving record.
        RunCommand acCmdSaveRecord
        'Move back a record if Count is negative, otherwise forward.
        RunCommand IIf(lngCount < 0&, acCmdRecordsGoToPrevious, acCmdRecordsGoToNext)
        DoMouseWheel = Sgn(lngCount)
    End If

Exit_Handler:
    Exit Function

Err_Handler:
    Select Case Err.Number
    Case 2046&                 'Can't move before first, after last, etc.
        Beep
    Case 3314&, 2101&, 2115&   'Can't save the current record.
        strMsg = "Cannot scroll to another record, as this one can't be saved."
        MsgBox strMsg, vbInformation, "Cannot scroll"
    Case Else
        strMsg = "Error " & Err.Number & ": " & Err.Description
        MsgBox strMsg, vbInformation, "Cannot scroll"
    End Select
    Resume Exit_Handler
End Function
Назад ToTop
L.E. 26.03.2017
Рейтинг@Mail.ru