Showing posts with label Horizontal-Scroll. Show all posts
Showing posts with label Horizontal-Scroll. Show all posts

Saturday, November 23, 2013

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
READ MORE - VB6 DataGrid: Mouse Wheel Scroll Horizontal ScrollBar +SHIFT

Tuesday, May 29, 2012

Horizontal Scroll And Vertical Scroll

Option Explicit 
  
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
  
Public Const SB_LINEUP As Long = 0 
Public Const SB_LINEDOWN As Long = 1 
  
Public Const WM_VSCROLL As Long = &H115 
Public Const WM_HSCROLL As Long = &H114 
Public Const WM_MOUSEWHEEL As Long = &H20A 
Public Const GWL_WNDPROC = (-4) 
  
Public PrevProc As Long 
Public blnFocusScroll As Boolean 
  
Function NewWindowProc(ByVal hWnd As Long, _ 
ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
On Error Resume Next 
    Select Case Msg 
        Case Is = WM_MOUSEWHEEL 
            If blnFocusScroll = True Then 
                If (wParam > 0) Then 
                    'Form1 adalah nama form yang akan akan digunakan 
                    'Scroll adalah nama scrollbar yang akan digunakan 
                    SendMessage Form1.Scroll.hWnd, WM_VSCROLL, SB_LINEUP, 0& 
                    Form1.Scroll.Value = Form1.Scroll.Value - _ 
                    Form1.Scroll.LargeChange 
                Else 
                    SendMessage Form1.Scroll.hWnd, WM_VSCROLL, SB_LINEDOWN, 0& 
                    Form1.Scroll.Value = Form1.Scroll.Value + _ 
                    Form1.Scroll.LargeChange 
                End If 
                Form1.Scroll_Change 
            End If 
        End Select 
        ' 
        NewWindowProc = CallWindowProc(PrevProc, hWnd, Msg, wParam, lParam) 
End Function 
  
Public Sub HookForm(F As Form) 
    PrevProc = SetWindowLong(F.hWnd, GWL_WNDPROC, AddressOf NewWindowProc) 
End Sub 
  
Public Sub UnHookForm(F As Form) 
    SetWindowLong F.hWnd, GWL_WNDPROC, PrevProc 
End Sub 

Dalam form tambahkan kode di bawah ini:

Option Explicit 
  
Dim AwalTop As Long 
  
Sub Scrolling(Value As Long) 
    Dim i As Long 
  
    picItem(0).Top = picItem(0).Top + (AwalTop - Value) 
  
    For i = 1 To picItem.Count - 1 
        picItem(i).Top = picItem(i - 1).Top + Me.picItem(0).Height + 20 
        DoEvents 
    Next 
  
    AwalTop = Value 
End Sub 
  
Private Sub Form_Load() 
    HookForm Me 
    blnFocusScroll = True 
    Me.Scroll.Max = 2500 
    Me.Scroll.SmallChange = 10 
    Me.Scroll.LargeChange = 100 
End Sub 
  
Private Sub Form_Unload(Cancel As Integer) 
    UnHookForm Me 
End Sub 
  
Sub Scroll_Change() 
    Scrolling Me.Scroll.Value 
End Sub 
  
Sub Scroll_Scroll() 
    Scrolling Me.Scroll.Value 
End Sub 

Perhatian:
Kode di atas menggunakan subclassing, kesalahan mengkode dapat menyebabkan CRASH!

READ MORE - Horizontal Scroll And Vertical Scroll