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

Assumptions

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

Public 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

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)

Code


'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
SubClass_Error:
  
'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
    
    Case WM_VSCROLL
      
      nRes = MsgBlaster.GetHiLoByte(wParam, LOBYTE, HIBYTE)
      If LOBYTE = SB_THUMBTRACK Or LOBYTE = SB_PAGEDOWN Or LOBYTE = SB_PAGEUP Then
       fEat = True
       intAction = 1
       pVert = True
      End If
    
    Case WM_HSCROLL
      
      nRes = MsgBlaster.GetHiLoByte(wParam, LOBYTE, HIBYTE)
      If LOBYTE = SB_THUMBTRACK Then
       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
  Else
    IMsgTarget_OnMsg = 1& 'Non-zero means we ate it
  End If
  
  If intAction = 1 Then SetScrollType pVert, LOBYTE
  
Exit Function
SubClass_Error:
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
     Case SB_THUMBTRACK
      DataGrid1.Scroll 0, typScroll.nTrackPos - typScroll.nPos
     Case SB_PAGEDOWN
      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
Else
  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

Categories

Visual Basic 6

Attachments

No attachments for this post


Loading Comments ...

Comments

No comments have been added for this post.

You must be logged in to make a comment.