Position of record in subform after refresh (and bookmark)

[Michael Schwab]

Hi everybody,

(I hope that I can explain this well)

I have a continous subform that holds more records that it can display.
After update of a record I have to refresh the form, which by default puts
the focus onto the first record. To stop this (and to stay in the same
record) I am using this routine:

Public Sub StayAtRecord(subForm As Control, strField As String, lngPK As
Long)
On Error GoTo HandleError

Dim rst As New ADODB.Recordset

Set rst = subForm.Form.Recordset.Clone
rst.Find (strField & "=") & lngPK
uForm.Form.Bookmark = rst.Bookmark
rst.Close

ExitHere:
Set rst = Nothing
Exit Sub
HandleError:
Resume ExitHere
End Sub

, which works fine, BUT it positions the record at the top of the subform
control. How can I get the subform not to scroll (and leave the position of
the record where it is)????

Thanks, Michael

 

[Michael Schwab]

Ah, forgot to say that it's an adp. In the meantime I have found a solution
based on Stephen Leban's DAO example (http://www.lebans.com/setgetsb.htm)
Appears to be working...thought I should post it, comments welcome, michael

Option Compare Database

Dim WithEvents rs As Recordset
Dim q As Boolean

Dim uFormSelTop As Long
Dim uFormCurrentSectionTop As Long


Private Sub MyRefresh()
On Error GoTo HandleError

Dim OrigSelTop As Long
Dim RowsFromTop As Long
Dim OrigCurrentSectionTop As Long

'cache values before refresh
OrigSelTop = uFormSelTop
OrigCurrentSectionTop = uFormCurrentSectionTop

Me.Painting = False

Me.Refresh

Set rs = Recordset

While q <> True
DoEvents
Wend

If Me.Section(acHeader).Visible = True Then
RowsFromTop = (OrigCurrentSectionTop - Me.Section(acHeader).Height) /
Me.Section(acDetail).Height
Else
RowsFromTop = OrigCurrentSectionTop / Me.Section(acDetail).Height
End If

Me.SelTop = Me.Recordset.RecordCount
Me.SelTop = OrigSelTop - RowsFromTop
DoEvents
Me.Recordset.AbsolutePosition = Me.CurrentRecord + RowsFromTop '- 1

ExitHere:
Me.Painting = True
Set rs = Nothing
Exit Sub
HandleError:
Resume ExitHere:
End Sub

Private Sub rs_FetchComplete(ByVal pError As ADODB.Error, adStatus As
ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
If adStatus = adStatusOK Then q = True
End Sub

Private Sub Form_Current()
uFormSelTop = Me.SelTop
uFormCurrentSectionTop = Me.CurrentSectionTop
End Sub