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

По материалам: 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