TopPicLogo TopPicText

Незаметное обновление записей формы

По материалам: http://access.mvps.org/access/

Используется при работе в сети, т.е. база одна - пользователей много.
Лучше по таймеру (каждые 5-10 секунд), можно по кнопке, или оба варианта вместе.

Пример использования:

Private Sub cmdUpdRecords_Click()
On Error GoTo cmdUpdRecords_Click_Err
'--------------------------------------------------------------------
'Пример вызова обновления подчинённой из главной формы по нажатию кнопки:
'    Me!objSubForm00.Form = Ссылка на обновляемую ПОДЧИНЁННУЮ форму
'    "exRecordID"         = название ПОЛЯ (не имя обьекта формы, а поля в источнике записей) _
                            содержащего уникальный индекс текущей записи
    
    esFormRequery Me!objsubForm00.Form, "exRecordID"

cmdUpdRecords_Click_Bye:
    Exit Sub

cmdUpdRecords_Click_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure cmdUpdRecords_Click", vbCritical, "Error!"
    Resume cmdUpdRecords_Click_Bye
End Sub


Модуль:

'--------------------------------------------------------------------
' Module    : modFormReсordsHidRequery
' Author    : Stephen Lebans Stephen@lebans.com http://www.lebans.com/
' Copyright : Lebans Holdings 1999 Ltd.
' Date      : 20.02.2000
' Changed   : es 07.04.2003 (Адаптация под свои нужды) - L.E. 18.11.2012
' Purpose   : Незаметное обновление записей формы
'--------------------------------------------------------------------
' Часть кода взята из примера "SetGetScrollbarsVer7.mdb"
' http://www.lebans.com/
'--------------------------------------------------------------------
Option Compare Database
Option Explicit

'--------------------------------------------------------------------
'Единственная видимая "снаружи" модуля процедура = esFormRequery (см. ниже)
'   производит "незаметное" (для пользователя) обновление записей формы;
'   для отображения изменений внесенных другими пользователями;
'   с восстановлением положения вертикальной (И только) полосы прокрутки
'   вызывается по таймеру или "в ручную", пример вызова:
'   esFormRequery Me!objsubForm00.Form, "RecordID"
'Где аргументы:
'   Me!objSubForm00.Form = Ссылка на обновляемую форму
'   "RecordID" = название ПОЛЯ (не обьекта формы а поля в источнике записей) содержащего уникальный индекс тек. записи
'--------------------------------------------------------------------
Private Type SCROLLINFO
    cbSize As Long
    fMask As Long
    nMin As Long
    nMax As Long
    nPage As Long
    nPos As Long
    nTrackPos As Long
End Type
'--------------------------------------------------------------------
Private Declare Function apiGetScrollInfo Lib "user32" _
    Alias "GetScrollInfo" (ByVal hWnd As Long, ByVal n As Long, _
    lpScrollInfo As SCROLLINFO) As Long
'--------------------------------------------------------------------
Declare Function apiSetScrollInfo Lib "user32" _
    Alias "SetScrollInfo" (ByVal hWnd As Long, ByVal n As Long, _
    lpcScrollInfo As SCROLLINFO, ByVal bool As Boolean) As Long
'--------------------------------------------------------------------
Private Declare Function apiGetWindow Lib "user32" _
    Alias "GetWindow" _
    (ByVal hWnd As Long, _
    ByVal wCmd As Long) _
    As Long
'--------------------------------------------------------------------
Private Declare Function apiGetWindowLong Lib "user32" _
    Alias "GetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long) As Long
'--------------------------------------------------------------------
Private Declare Function apiGetClassName Lib "user32" _
    Alias "GetClassNameA" _
    (ByVal hWnd As Long, ByVal lpClassname As String, _
    ByVal nMaxCount As Long) As Long
'--------------------------------------------------------------------
Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" (ByVal hWnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'--------------------------------------------------------------------
Private Const GWL_STYLE = (-16)
Private Const SBS_VERT = &H1&
' ScrollInfo fMask's
Private Const SIF_ALL = &H4
'--------------------------------------------------------------------
' Scroll Bar Constants
'Private Const SB_HORZ = 0
Private Const SB_CTL = 2
'Private Const SB_VERT = 1
'--------------------------------------------------------------------
' Windows Message Constant
Private Const WM_VSCROLL = &H115
'Private Const WM_HSCROLL = &H114
'--------------------------------------------------------------------
' Scroll Bar Commands
'--------------------------------------------------------------------
Private Const SB_THUMBPOSITION = 4
'--------------------------------------------------------------------
' GetWindow() Constants
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5
'--------------------------------------------------------------------


Public Sub esFormRequery(frm As Form, strIDXField As String)
'Единственная видимая "снаружи" модуля процедура
Dim lngScrollPos As Long      'Позиция вертик. полосы прокрутки
Dim lngIndexVal As Long       'Значение поля индекса
Dim strCriteria As String     'Условия отбора
'--------------------------------------------------------------------
'es 28.02.2003
'Производит в форме ОБНОВЛЕНИЕ записей и потом поиск записи на которой находился
'   курсор с восстановлением положения полосы прокрутки если запись не
'   найдена (другой пользователь ее удалил) - переход на Предидущую запись
'АРГУМЕНТЫ:
'   frm - ссылка на обновляемую форму
'   strIDXField - название поля в источнике данных с уникальным индекссом записи (LONG)
'--------------------------------------------------------------------
On Error GoTo FormRequeryErr

'Получяем позицию вертикальной полосы прокрутки...
    lngScrollPos = fGetScrollBarPos(frm)
    
'Формируем критерии будущего поиска тек. записи
    lngIndexVal = esGetRecordID(frm, strIDXField) 'см фунцкию ниже
    strCriteria = strIDXField & " = " & lngIndexVal
    
'Обновляем форму и пытеемся встать туда же где и стояли ДО ОБНОВЛЕНИЯ
    With frm
        .RecordSource = .RecordSource
        .RecordsetClone.FindFirst strCriteria
        'если полный крах затеи - то на выход....
        If .RecordsetClone.NoMatch Then GoTo FormRequeryBye
        'Запись найдена - ставим на нее курсор
       .Bookmark = .RecordsetClone.Bookmark
    End With
' ТЕПЕРЬ Восстанавливаем положение полосы прокрутки
    fSetScrollBarPos frm, lngScrollPos
    Set frm = Nothing
    DoEvents

FormRequeryBye:
    Exit Sub
    
FormRequeryErr:
    'Debug.Print Err.Description & " = " & Err.Number
    Err.Clear
    Resume FormRequeryBye
End Sub
Private Function esGetRecordID(frm As Form, FieldName As String) As Long
'Возвращает ID записи
'   + Переводит курсор на предидущую (следующую) запись в ситуации
'   когда она удалена другим пользователем
'--------------------------------------------------------------------
Dim rst As Recordset
Const intRetr As Integer = 50   'Кол-во повторений попыток перехода на ближайшую запись
Dim intDone As Integer          'Кол-во произведенных переходов

GetRecordIDStart:
    On Error GoTo GetRecordIDErr
    esGetRecordID = frm(FieldName)
    GoTo GetRecordIDBye

GetRecordIDErr:
    Select Case Err.Number
        Case 3167    'Запись уже удалена
            Err.Clear
            'Если это была ЕДИНСТВЕННАЯ запись то и делать нечего...
            If frm.RecordsetClone.RecordCount = 2 Then
                esGetRecordID = 0
                GoTo GetRecordIDBye
            End If
            'Запись не последняя - продолжаем ...
            '   - Если лимит повторений не исчерпан то определяем в
            '     какую сторону будем двигаться (предпочтительно вверх)
            If intDone <> intRetr Then
                On Error GoTo GetRecordIDDeadErr
                Set rst = frm.RecordsetClone
                rst.Bookmark = frm.Bookmark
                rst.MovePrevious
                frm.Bookmark = rst.Bookmark
                intDone = intDone + 1
            End If
            Err.Clear
            Resume GetRecordIDStart
   End Select
   
GetRecordIDBye:
    'Debug.Print "esGetRecordID : Произведено повторений перехода : " & intDone
    Exit Function
   
GetRecordIDDeadErr:
   esGetRecordID = 0
   Err.Clear
   Resume GetRecordIDBye
End Function


Private Function fGetScrollBarPos(frm As Form) As Long
' Return ScrollBar Thumb position for the Vertical Scrollbar attached to the
'--------------------------------------------------------------------
Dim hWndSB As Long
Dim lngret As Long
Dim sInfo As SCROLLINFO
On Error GoTo GetScrollBarPosErr
    ' Init SCROLLINFO structure
    sInfo.fMask = SIF_ALL
    sInfo.cbSize = Len(sInfo)
    sInfo.nPos = 0
    sInfo.nTrackPos = 0
    
    ' Call function to get handle to ScrollBar control if it is visible
    hWndSB = fIsScrollBar(frm)
    If hWndSB = -1 Then
        fGetScrollBarPos = False
        Exit Function
    End If
    
    ' Get the window's ScrollBar position
    lngret = apiGetScrollInfo(hWndSB, SB_CTL, sInfo)
    'Debug.Print "nPos:" & sInfo.nPos & "  nPage:" & sInfo.nPage & "  nMax:" & sInfo.nMax
    'MsgBox "getscrollinfo returned " & sInfo.nPos & " , " & sInfo.nTrackPos
    fGetScrollBarPos = sInfo.nPos + 1
    Exit Function
GetScrollBarPosErr:
    Err.Clear
    fGetScrollBarPos = 0
End Function
Private Function fSetScrollBarPos(frm As Form, lngIndex As Long) As Long
' Set the Thumb Position for the
' Vertical ScrollBar of the Form passed to
' this Function.
' Remember that we must subtract 1 from the value
' passed to this Fiunction for the desired
' Scrollbar position
'--------------------------------------------------------------------
' *** LIMITED TO 32K ***
' Need to use ScrollInfo to overcome this limit
' Also need to figure out how Access\
' calculates the ScrollBar page size!
'--------------------------------------------------------------------
Dim hWndSB As Long
Dim lngret As Long
Dim LngThumb As Long
On Error GoTo SetScrollBarPosErr
' Call function to get handle to
' ScrollBar control if it is visible
    hWndSB = fIsScrollBar(frm)
    If hWndSB = -1 Then
        fSetScrollBarPos = False
        Exit Function
    End If

' Set the value  for the ScrollBar.
' This corresponds to the top most record
' that will be displayed in the Form.
    LngThumb = MakeDWord(SB_THUMBPOSITION, CInt(lngIndex - 1))
    lngret = SendMessage(frm.hWnd, WM_VSCROLL, ByVal LngThumb, ByVal hWndSB)
' Return Success as our new ScrollBar Position
    fSetScrollBarPos = lngIndex
SetScrollBarPosBye:
    Exit Function
SetScrollBarPosErr:
    Err.Clear
    Resume SetScrollBarPosBye
End Function

Private Function fIsScrollBar(frm As Form) As Long
' Get ScrollBar's hWnd
Dim hWnd_VSB As Long
Dim hWnd As Long
   
On Error GoTo IsScrollBarErr
    hWnd = frm.hWnd
    
    ' Let's get first Child Window of the FORM
    hWnd_VSB = apiGetWindow(hWnd, GW_CHILD)
                
    ' Let's walk through every sibling window of the Form
    Do
        ' Thanks to Terry Kreft for explaining
        ' why the apiGetParent acll is not required.
        ' Terry is in a Class by himself! :-)
        'If apiGetParent(hWnd_VSB) &lt;= hWnd Then Exit Do
            
        If fGetClassName(hWnd_VSB) = "scrollBar" Then
            If apiGetWindowLong(hWnd_VSB, GWL_STYLE) And SBS_VERT Then
                fIsScrollBar = hWnd_VSB
                Exit Function
            End If
        End If
    
    ' Let's get the NEXT SIBLING Window
    hWnd_VSB = apiGetWindow(hWnd_VSB, GW_HWNDNEXT)
    
    ' Let's Start the process from the Top again
    ' Really just an error check
    Loop While hWnd_VSB <> 0
    
    ' SORRY - NO Vertical ScrollBar control
    ' is currently visible for this Form
    fIsScrollBar = -1
IsScrollBarBye:
    Exit Function
IsScrollBarErr:
    Err.Clear
    Resume IsScrollBarBye
End Function
Private Function fGetClassName(hWnd As Long)
Dim strBuffer As String
Dim lngLen As Long
Const MAX_LEN = 255
On Error GoTo GetClassNameErr
    strBuffer = Space$(MAX_LEN)
    lngLen = apiGetClassName(hWnd, strBuffer, MAX_LEN)
    If lngLen = 0 Then fGetClassName = Left$(strBuffer, lngLen)
GetClassNameBye:
    Exit Function
GetClassNameErr:
    Err.Clear
    Resume GetClassNameBye
End Function
' Here's the MakeDWord function from the MS KB
Private Function MakeDWord(loword As Integer, hiword As Integer) As Long
    MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function


Назад ToTop
L.E. 29.12.2012
Рейтинг@Mail.ru