GFScroll/Mfrm.frm
VERSION 5.00
Begin VB.Form Mfrm
Caption = "Form1"
ClientHeight = 3195
ClientLeft = 60
ClientTop = 345
ClientWidth = 4635
LinkTopic = "Form1"
ScaleHeight = 3195
ScaleWidth = 4635
StartUpPosition = 3 'Windows‑Standard
Begin VB.CommandButton Command3
Caption = "Set Pos"
Height = 375
Left = 60
TabIndex = 7
Top = 2640
Width = 1275
End
Begin VB.CommandButton Command2
Caption = "Get Pos"
Height = 375
Left = 60
TabIndex = 6
Top = 2280
Width = 1275
End
Begin VB.CommandButton Command1
Caption = "To Pos"
Height = 375
Left = 1740
TabIndex = 5
Top = 2460
Width = 1275
End
Begin VB.CommandButton RightCommand
Height = 375
Left = 3900
TabIndex = 4
Top = 2460
Width = 375
End
Begin VB.CommandButton DownCommand
Height = 375
Left = 3540
TabIndex = 2
Top = 2460
Width = 375
End
Begin VB.CommandButton UpCommand
Height = 375
Left = 3540
TabIndex = 1
Top = 2100
Width = 375
End
Begin VB.CommandButton LeftCommand
Height = 375
Left = 3180
TabIndex = 3
Top = 2460
Width = 375
End
Begin VB.TextBox Text1
Height = 1935
Left = 60
MultiLine = ‑1 'True
ScrollBars = 3 'Beides
TabIndex = 0
Top = 60
Width = 3855
End
End
Attribute VB_Name = "Mfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis. Use to scroll any window/control.
'GF[H/V]Scroll
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
'GFGetScrollPos
Private Declare Function GetScrollInfo Lib "user32" (ByVal hWnd As Long, ByVal n As Long, lpScrollInfo As SCROLLINFO) As Long
'LOWORD, HIWORD (GF[H/V]Scroll)
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'GFGetScrollPos
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
'GF[H/V]Scroll
Const WM_HSCROLL = &H114
Const WM_VSCROLL = &H115
Const SB_LINEUP = 0
Const SB_LINEDOWN = 1
Const SB_LINELEFT = 0
Const SB_LINERIGHT = 1
Const SB_PAGEUP = 2
Const SB_PAGEDOWN = 3
Const SB_PAGELEFT = 2
Const SB_PAGERIGHT = 3
Const SB_THUMBPOSITION = 4
Const SB_THUMBTRACK = 5
'GFGetScrollPos
Private Const SB_HORZ = 0
Private Const SB_VERT = 1
Private Const SIF_RANGE As Long = &H1
Private Const SIF_PAGE As Long = &H2
Private Const SIF_POS As Long = &H4
Private Const SIF_DISABLENOSCROLL As Long = &H8
Private Const SIF_TRACKPOS As Long = &H10
Private Const SIF_ALL As Long = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS)
'DEBUG
Dim ScrollPosX As Long 'global
Dim ScrollPosY As Long 'global
'***DEBUG***
Private Sub Form_Load()
'on error resume next
Dim Temp1 As Long
Dim Temp2 As Long
Dim Tempstr$
For Temp1 = 1 To 100
For Temp2 = 1 To 100
Tempstr$ = Tempstr$ + Chr$(Int((128 ‑ 32 + 1) * Rnd(1) + 32))
Next Temp2
Tempstr$ = Tempstr$ + Chr$(13) + Chr$(10)
Next Temp1
Text1.Text = Tempstr$
End Sub
Private Sub UpCommand_Click()
'on error resume next
Call GFVScroll(Text1.hWnd, SB_LINEUP, 0)
End Sub
Private Sub DownCommand_Click()
'on error resume next
Call GFVScroll(Text1.hWnd, SB_LINEDOWN, 0)
End Sub
Private Sub LeftCommand_Click()
'on error resume next
Call GFHScroll(Text1.hWnd, SB_LINELEFT, 0)
End Sub
Private Sub RightCommand_Click()
'on error resume next
Call GFHScroll(Text1.hWnd, SB_LINERIGHT, 0)
End Sub
Private Sub Command1_Click()
'on error resume next
Call GFHScroll(Text1.hWnd, SB_THUMBTRACK, 50)
Call GFVScroll(Text1.hWnd, SB_THUMBTRACK, 50)
End Sub
Private Sub Command2_Click()
'on error resume next
'Dim ScrollPosX As Long 'global
'Dim ScrollPosY As Long 'global
'begin
Debug.Print GFGetScrollPos(Text1.hWnd, ScrollPosX, ScrollPosY)
Debug.Print ScrollPosX, ScrollPosY
End Sub
Private Sub Command3_Click()
'on error resume next
Call GFHScroll(Text1.hWnd, SB_THUMBPOSITION, ScrollPosX)
Call GFVScroll(Text1.hWnd, SB_THUMBPOSITION, ScrollPosY)
End Sub
'***END OF DEBUG***
Private Sub GFHScroll(ByVal TargethWnd As Long, ByVal ScrollType As Long, ByVal ScrollPos As Integer)
'on error resume next 'use one of the SB_X constants (ScrollPos needs only to be passed for SB_THUMBPOSITION)
Dim WORD As Long
'preset
Call CopyMemory(ByVal VarPtr(WORD), ScrollType, 2)
Call CopyMemory(ByVal VarPtr(WORD) + 2, ScrollPos, 2)
'begin
Call SendMessage(TargethWnd, WM_HSCROLL, WORD, 0&) 'return value not clear
End Sub
Private Sub GFVScroll(ByVal TargethWnd As Long, ByVal ScrollType As Long, ByVal ScrollPos As Integer)
'on error resume next 'use one of the SB_X constants (ScrollPos needs only to be passed for SB_THUMBPOSITION)
Dim WORD As Long
'preset
Call CopyMemory(ByVal VarPtr(WORD), ScrollType, 2)
Call CopyMemory(ByVal VarPtr(WORD) + 2, ScrollPos, 2)
'begin
Call SendMessage(TargethWnd, WM_VSCROLL, WORD, 0&) 'return value not clear
End Sub
Private Function GFGetScrollPos(ByVal TargethWnd As Long, ByRef ScrollPosX As Long, ByRef ScrollPosY As Long) As Boolean
'on error resume next 'returns True if scroll values have been set, False if not (error)
Dim SCROLLINFOVar As SCROLLINFO
'begin
SCROLLINFOVar.cbSize = Len(SCROLLINFOVar)
SCROLLINFOVar.fMask = SIF_POS
If GetScrollInfo(TargethWnd, SB_HORZ, SCROLLINFOVar) = 0 Then GoTo Error: 'verify
ScrollPosX = SCROLLINFOVar.nPos
SCROLLINFOVar.cbSize = Len(SCROLLINFOVar)
SCROLLINFOVar.fMask = SIF_POS
If GetScrollInfo(TargethWnd, SB_VERT, SCROLLINFOVar) = 0 Then GoTo Error: 'verify
ScrollPosY = SCROLLINFOVar.nPos
GFGetScrollPos = True 'ok
Exit Function
Error:
GFGetScrollPos = False 'error
Exit Function
End Function
'NOTE: the LOWORD() and HIWORD() functions are not in use but only CopyMemory().
Private Function LOWORD(ByVal n As Long) As Integer
'on error resume next 'returns the low word of n
Call CopyMemory(LOWORD, ByVal VarPtr(n) + 2, 2)
End Function
Private Function HIWORD(ByVal n As Long) As Integer
'on error resume next 'returns the high word of n
Call CopyMemory(HIWORD, ByVal VarPtr(n) + 0, 2)
End Function
[END OF FILE]