Search Tools Links Login

Smooth Scrolling DataGrid

This code allows you to have the smooth-scrolling effect seen in better applications on your datagrids(could also apply to other scroll bars in VB)
When you grab the trackbar and move it, VB doesn't do anything until you let go. Or if you click on the trackbar itself, the grid just jumps.
This code shows you how to change these effects so that the grid(or text) will scroll smoothly as you drag or click.

Original Author: Darryn Frost


I used the "MsgBlaster" .Bas module and type library for the subclassing, they are available free on the net, and I will upload it in a seperate Listing here right after this one

API Declarations

cbSize As Long
fMask As Long
nMin As Long
nMax As Long
nPage As Long
nPos As Long
nTrackPos As Long
End Type

Public Const WM_HSCROLL = &H114
Public Const WM_VSCROLL = &H115
' Scroll Bar Commands
Public Const SB_PAGEUP = 2
Public Const SB_PAGEDOWN = 3
Public Const SB_THUMBTRACK = 5
' Scroll Bar Constants
Public Const SB_HORZ = 0
Public Const SB_VERT = 1
Public Const SB_CTL = 2
Public Const SB_BOTH = 3
Public Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)


'This is for a form with a datagrid
Option Explicit
Private m_Grid_Subclassed As Boolean
Private Const msCustomMessageName As String = "MsgBlasterCustomMessage"
Private mlCustomMessageID As Long
Private rglMsgIDs() As Long
Implements IMsgTarget
Private Sub Form_Load()
'Open a recordset and bind the grid to it here
Call SubClassGrid

End Sub
Private Sub SubClassGrid()

On Error GoTo SubClass_Error
If Not m_Grid_Subclassed = True Then

  'To prevent it from trying again, since that can cause problems
  m_Grid_Subclassed = True
  ' Register our custom message to get the message id.
  mlCustomMessageID = RegisterWindowMessage(msCustomMessageName)
  'The windows messages we are interested in are WM_VSCROLL and WM_HSCROLL
  ReDim rglMsgIDs(1 To 3) As Long
  rglMsgIDs(1) = WM_VSCROLL
  rglMsgIDs(2) = WM_HSCROLL
  rglMsgIDs(3) = mlCustomMessageID
  MsgBlaster.SubclassWindow DataGrid1.hWnd, Me, rglMsgIDs
End If
Exit Sub
'Since this is not a critical error, just ignore it for the user
Exit Sub
End Sub
Private Function IMsgTarget_OnMsg( _
ByVal hWnd As Long, _
ByVal msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim LOBYTE As Integer
Dim HIBYTE As Integer
Dim nRes As Long
Dim fEat As Boolean
Dim intAction As Integer
Dim pVert As Boolean

On Error GoTo SubClass_Error
  'If this is False, the message will be passed along the chain
  'If it is True, it will not be passed on
  fEat = False
  intAction = 0
  Select Case msg
      nRes = MsgBlaster.GetHiLoByte(wParam, LOBYTE, HIBYTE)
       fEat = True
       intAction = 1
       pVert = True
      End If
      nRes = MsgBlaster.GetHiLoByte(wParam, LOBYTE, HIBYTE)
       fEat = True
       intAction = 1
       pVert = False
      End If
    Case mlCustomMessageID
     'lstLog.AddItem msCustomMessageName & vbTab & "wParam=0x" & Hex$(wParam) & vbTab & "lParam=0x" & Hex$(lParam)
  End Select

  If fEat = False Then
    IMsgTarget_OnMsg = _
      MsgBlaster.CallOrigWndProc(hWnd, msg, wParam, lParam)
    Exit Function
    IMsgTarget_OnMsg = 1& 'Non-zero means we ate it
  End If
  If intAction = 1 Then SetScrollType pVert, LOBYTE
Exit Function
Exit Function

End Function
Private Sub SetScrollType(ByVal pVert As Boolean, ByVal pLoByte As Integer)

Dim hWndVert As Long
Dim hWndHorz As Long
Dim typScroll As SCROLLINFO
Dim i As Integer

'Looking for Vertical scroll bar
hWndVert = FindWindowEx(DataGrid1.hWnd, 0&, "ScrollBar", vbNullString)
'Looking for Horizontal scroll bar
hWndHorz = FindWindowEx(DataGrid1.hWnd, hWndVert, "ScrollBar", vbNullString)

If pVert = True Then
  If Not hWndVert = 0 Then
    typScroll.cbSize = LenB(typScroll)
    typScroll.fMask = 31
   If GetScrollInfo(hWndVert, SB_CTL, typScroll) <> 0 Then
    Select Case pLoByte
      DataGrid1.Scroll 0, typScroll.nTrackPos - typScroll.nPos
      For i = 1 To DataGrid1.VisibleRows - 1
       DataGrid1.Scroll 0, 1
       Sleep 25
      Next i
     Case SB_PAGEUP
      For i = 1 To DataGrid1.VisibleRows - 1
       DataGrid1.Scroll 0, -1
       Sleep 25
      Next i
    End Select
   End If
  End If
  If Not hWndHorz = 0 Then
    typScroll.cbSize = LenB(typScroll)
    typScroll.fMask = 31
   If GetScrollInfo(hWndHorz, SB_CTL, typScroll) <> 0 Then
     DataGrid1.Scroll typScroll.nTrackPos - typScroll.nPos, 0
   End If
  End If
End If
End Sub

About this post

Posted: 2002-06-01
By: ArchiveBot
Viewed: 190 times


Visual Basic 6


No attachments for this post

Loading Comments ...


No comments have been added for this post.

You must be logged in to make a comment.