1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
| Option Compare Database
Option Explicit
' ****CODE START****
' Place this code in a standard module.
' make sure you do not name the module
' to conflict with any of the functions below.
'Author: Stephen Lebans
' Stephen@lebans.com
' www.lebans.com
' Feb.20, 2000
'
'Copyright: Lebans Holdings 1999 Ltd.
'
'Functions: fGetScrollBarPos(frm As Form) As Long
' fSetScrollBarPos(frm As Form, lngIndex As Long) As Long
'
'Credits: Dev Ashish, Terry Kreft
' The Access Web
' http://www.mvps.org/access/
'
'Why?: Somebody asked for it!
'
'BUGS: Let me know!
' :-)
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
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Const GWL_HINSTANCE = (-6)
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 Declare Function apiGetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hWnd As Long, _
ByVal lpClassname As String, _
ByVal nMaxCount As Long) _
As Long
Private Declare Function apiGetParent Lib "user32" _
Alias "GetParent" _
(ByVal hWnd 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 apiGetWindow Lib "user32" _
Alias "GetWindow" _
(ByVal hWnd As Long, _
ByVal wCmd As Long) _
As Long
'Private Const ACC_MAIN_CLASS = "OMain"
'Private Const ACC_FORM_CLASS = "OForm"
Private Const GWL_STYLE = (-16)
' Window Style Flags
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000
' Scroll Bar Styles
Private Const SBS_HORZ = &H0&
Private Const SBS_VERT = &H1&
Private Const SBS_SIZEBOX = &H8&
' ScrollBar Message
Private Const SBM_SETPOS = &HE0
Private Const SBM_GETPOS = &HE1 '/*not in win3.1 */
Private Const SBM_SETRANGE = &HE2 '/*not in win3.1 */
Private Const SBM_SETRANGEREDRAW = &HE6 '/*not in win3.1 */
Private Const SBM_GETRANGE = &HE3 '/*not in win3.1 */
Private Const SBM_ENABLE_ARROWS = &HE4 '/*not in win3.1 */
'#if(WINVER >= 0x0400)
Private Const SBM_SETSCROLLINFO = &HE9
Private Const SBM_GETSCROLLINFO = &HEA
' ScrollInfo fMask's
Private Const SIF_RANGE = &H1
Private Const SIF_PAGE = &H2
Private Const SIF_POS = &H4
Private Const SIF_DISABLENOSCROLL = &H8
Private Const SIF_TRACKPOS = &H10
Private Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS)
' 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_LINEUP = 0
Private Const SB_LINELEFT = 0
Private Const SB_LINEDOWN = 1
Private Const SB_LINERIGHT = 1
Private Const SB_PAGEUP = 2
Private Const SB_PAGELEFT = 2
Private Const SB_PAGEDOWN = 3
Private Const SB_PAGERIGHT = 3
Private Const SB_THUMBPOSITION = 4
Private Const SB_THUMBTRACK = 5
Private Const SB_TOP = 6
Private Const SB_LEFT = 6
Private Const SB_BOTTOM = 7
Private Const SB_RIGHT = 7
Private Const SB_ENDSCROLL = 8
' GetWindow() Constants
'Private Const GW_HWNDFIRST = 0
'Private Const GW_HWNDLAST = 1
Private Const GW_HWNDNEXT = 2
'Private Const GW_HWNDPREV = 3
'Private Const GW_OWNER = 4
Private Const GW_CHILD = 5
'Private Const GW_MAX = 5
Public Function fGetScrollBarPos(frm As Form) As Long
' Return ScrollBar Thumb position
' for the Vertical Scrollbar attached to the
' Form passed to this Function.
Dim hWndSB As Long
Dim lngret As Long
Dim sInfo As SCROLLINFO
' 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
End Function
Public Function fGetScrollBarPosHZ(frm As Form) As Long
' Return ScrollBar Thumb position
' for the Horizontal Scrollbar attached to the
' Form passed to this Function.
Dim hWndSB As Long
Dim lngret As Long
Dim sInfo As SCROLLINFO
' 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 = fIsScrollBarHZ(frm)
If hWndSB = -1 Then
fGetScrollBarPosHZ = False
Exit Function
End If
'Debug.Print "hwndSB:" & Hex(hWndSB)
'Debug.Print
' 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
fGetScrollBarPosHZ = sInfo.nPos + 1
End Function
Public 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
' 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
End Function
Public Function fSetScrollBarPosHZ(frm As Form, lngIndex As Long) As Long
' Set the Thumb Position for the
' Horizontal ScrollBar of the Form passed to
' this Function.
' Remember that we must subtract 1 from the value
' passed to this Function 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
' Call function to get handle to
' ScrollBar control if it is visible
hWndSB = fIsScrollBarHZ(frm)
If hWndSB = -1 Then
fSetScrollBarPosHZ = 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_HSCROLL, ByVal LngThumb, ByVal hWndSB)
' Return Success as our new ScrollBar Position
fSetScrollBarPosHZ = lngIndex
End Function
Private Function fIsScrollBar(frm As Form) As Long
' Get ScrollBar's hWnd
Dim hWnd_VSB As Long
Dim hWnd As Long
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) <> 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
End Function
Private Function fIsScrollBarHZ(frm As Form) As Long
' Get ScrollBar's Horizontal hWnd
Dim hWnd_VSB As Long
Dim hWnd As Long
Dim lngStyle As Long
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) <> hWnd Then Exit Do
If fGetClassName(hWnd_VSB) = "scrollBar" Then
lngStyle = apiGetWindowLong(hWnd_VSB, GWL_STYLE)
If (lngStyle And SBS_SIZEBOX) = False Then
'If apiGetWindowLong(hWnd_VSB, GWL_STYLE) And SBS_HORZ Then
If (lngStyle And 1) = SBS_HORZ Then
fIsScrollBarHZ = hWnd_VSB
Exit Function
End If
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
fIsScrollBarHZ = -1
End Function
' From Dev Ashish's Site
' The Access Web
' http://www.mvps.org/access/
'******* Code Start *********
Private Function fGetClassName(hWnd As Long)
Dim strBuffer As String
Dim lngLen As Long
Const MAX_LEN = 255
strBuffer = Space$(MAX_LEN)
lngLen = apiGetClassName(hWnd, strBuffer, MAX_LEN)
If lngLen > 0 Then fGetClassName = Left$(strBuffer, lngLen)
End Function
'******* Code End *********
' 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 '***END CODE
Public Function fSetScrollBarPos1(frm As Form, lngIndex As Long) As Long
' *** WARNING***
' ***DO NOT USE THIS FUNCTION YET! ***
' 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
' Here we are trying to overcome the 32K limit.
' We can get to 64K by rolling our own Unsigned Integer
' vs the VB SignedInteger but I want the
' whole enchelada!<bg>
' I've got it working but I need a bit more time
' tp understand the Logic Access uses to set
' the ScrollBar Page size. It is not always straightforward!!
Dim hWndSB As Long
Dim lngret As Long
Dim LngThumb As Long
Dim sInfo As SCROLLINFO
' Init SCROLLINFO structure
sInfo.fMask = SIF_POS
sInfo.cbSize = Len(sInfo)
sInfo.nPos = lngIndex
sInfo.nTrackPos = 0
' Call function to get handle to
' ScrollBar control if it is visible
hWndSB = fIsScrollBar(frm)
If hWndSB = -1 Then
fSetScrollBarPos1 = 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.
If lngIndex >= 65536 / 2 Then lngIndex = (65536 / 2) - lngIndex
LngThumb = MakeDWord(SB_THUMBPOSITION, CInt(lngIndex - 1))
lngret = apiSetScrollInfo(hWndSB, SB_CTL, sInfo, True)
DoEvents
'lngRet = SendMessage(hWndSB, SBM_SETPOS, lngIndex, ByVal True)
'lngRet = SendMessage(frm.hWnd, WM_VSCROLL, ByVal SB_ENDSCROLL, ByVal hWndSB)
' this one below works
'lngRet = SendMessage(frm.hWnd, WM_VSCROLL, ByVal LngThumb, ByVal 0&)
' Return Success as our new ScrollBar Position
fSetScrollBarPos1 = lngIndex
End Function
Public Function fQuery(garbage As Variant) As Long
' Return ScrollBar Thumb position
' for the Vertical Scrollbar attached to the
' Form passed to this Function.
Const SB_BOTTOM = 7
On Error GoTo Exit_Query
Dim hWndSB As Long
Dim lngret As Long
Dim sInfo As SCROLLINFO
Dim frm As Form
Set frm = Screen.ActiveForm
' 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
fQuery = -1
Set frm = Nothing
Exit Function
End If
'lngRet = SendMessage(frm.hWnd, WM_VSCROLL, SB_BOTTOM, 0&)
' 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
'fQuery = sInfo.nPos + 1
fQuery = sInfo.nMax
Debug.Print "MAX RECS:" & sInfo.nMax
' 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)
'lngRet = SendMessage(frm.hWnd, WM_VSCROLL, SB_BOTTOM, 0&)
End_Query:
Set frm = Nothing
Exit Function
Exit_Query:
fQuery = -1
Resume End_Query
End Function |
Méthode Requery and Return to Current Row
Répondre avec citation
Partager