VB6 DataGrid: Mouse Wheel Scroll Horizontal ScrollBar +SHIFT

Jika kita mencari source code untuk men-scroll DataGrid dari atas ke bawah (vertikal) tentu tidak akan kesulitan, tetapi bagaimana jika scroll-nya menyamping dari kiri ke kanan (horizontal) yang disertai dengan menekan tombol SHIFT? Nah, di bawah ini merupakan salah satu contoh source codenya, dengan mengimplentasikan SubClassing menggunakan komponen SSubTmr6.dll seperti yang telah diposting sebelumnya. 

Form:

Option Explicit 
 
Dim WithEvents cMouse As cDataGridScroll 
 
'-------------------------------------------------------------------------- 
' http://khoiriyyah.blogspot.com 
' menggunakan component VBAccelerator SSubTmr6.dll Steve McMahon 
'-------------------------------------------------------------------------- 
 
Private Sub Form_Activate() 
    If DataGrid1.hWndEditor <> 0 Then cMouse.AttacthHWNDEditor 
End Sub 
 
Private Sub Form_Load() 
    With Adodc1 
        .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=biblio.mdb;Persist Security Info=False" 
        .RecordSource = "Select * from [titles]" 
        .Refresh 
        .Recordset.MoveFirst 
    End With 
    Set DataGrid1.DataSource = Adodc1 
    DataGrid1.Refresh 
    Set cMouse = New cDataGridScroll 
    With cMouse 
        .DataGrid = DataGrid1 
    End With 
End Sub 
 
Private Sub Form_Resize() 
    On Error Resume Next 
    DataGrid1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight 
End Sub 
 
Private Sub Form_Unload(Cancel As Integer) 
    Set cMouse = Nothing 
End Sub 

Class (cDataGridScroll.cls):

Option Explicit 
 
Implements ISubclass 
 
'-------------------------------------------------------------------------- 
' http://khoiriyyah.blogspot.com 
' menggunakan component VBAccelerator SSubTmr6.dll Steve McMahon 
'-------------------------------------------------------------------------- 
 
Private Const WM_MOUSEWHEEL = &H20A 
Private Const WHEEL_DELTA = 120 
Private Const MK_SHIFT = &H4 
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal cbSrc As Long) 
 
Public Event MouseScroll(Shift As Integer) 
Private WithEvents dtGrid As DataGrid 
Dim GSubclass As New GSubclass 
 
Public Sub AttacthHWNDEditor() 
    GSubclass.AttachMessage Me, dtGrid.hWndEditor, WM_MOUSEWHEEL 
End Sub 
 
Public Property Let DataGrid(New_DataGrid As DataGrid) 
    Set dtGrid = New_DataGrid 
    GSubclass.AttachMessage Me, dtGrid.hwnd, WM_MOUSEWHEEL 
End Property 
 
Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer6.EMsgResponse) 
' 
End Property 
 
Private Property Get ISubclass_MsgResponse() As SSubTimer6.EMsgResponse 
' 
End Property 
 
Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
    Dim fwKeys As Integer, zDelta As Integer 
    Static intHScroll As Integer 
    Select Case iMsg 
        Case WM_MOUSEWHEEL 
            fwKeys = LoWord(wParam) 
            zDelta = HiWord(wParam) / WHEEL_DELTA 
            'Debug.Print "fwKeys: " & fwKeys 
            'Debug.Print "zDelta: " & zDelta 
            If fwKeys = 4 Then '+SHIFT 
                intHScroll = intHScroll + 1 
                If intHScroll > 5 Then 'memperlambat horizontal scroll 
                    If zDelta > 0 Then 
                       dtGrid.Scroll -1, 0 
                    Else 
                       dtGrid.Scroll 1, 0 
                    End If 
                    intHScroll = 0 
                End If 
            ElseIf fwKeys = 0 Then 
                If zDelta > 0 Then 
                   dtGrid.Scroll 0, -1 
                Else 
                   dtGrid.Scroll 0, 1 
                End If 
            ElseIf fwKeys = 8 Then '+CTRL 'ZOOM 
                If zDelta > 0 Then 
                   dtGrid.Font.Size = dtGrid.Font.Size + 1 
                Else 
                    If dtGrid.Font.Size > 2 Then 
                        dtGrid.Font.Size = dtGrid.Font.Size - 1 
                    End If 
                End If 
            End If 
    End Select 
End Function 
 
Private Sub Class_Terminate() 
    GSubclass.DetachMessage Me, dtGrid.hwnd, WM_MOUSEWHEEL 
    Set GSubclass = Nothing 
    Set dtGrid = Nothing 
End Sub 
 
Function LoWord(ByVal dwDoubleWord As Long) As Integer 
    Call CopyMemory(LoWord, dwDoubleWord, 2) 
End Function 
 
Function HiWord(ByVal dwDoubleWord As Long) As Integer 
    Call CopyMemory(HiWord, ByVal VarPtr(dwDoubleWord) + 2, 2) 
End Function