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

VB6 DataGrid: Mengatur Tinggi Listitem Dropdown

Membahas hal yang kurang penting mengenai cara mengatur tinggi Listitem pada dropdown datagrid. Seperti biasa menggunakan fungsi API SendMessage yang bisa dilihat penjelasannya disini, kemudian beberapa konstanta ListBox yang bisa Anda lihat penjelasannya disini, serta konstanta ComboBox yang bisa Anda lihat penjelasannya disini.

Option Explicit 
 
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 
Private Const LB_SETITEMHEIGHT = &H1A0 
Private Const CB_SETITEMHEIGHT = &H15 
 
Private Sub SetListItemHeight(ctrl As Control, ByVal newHeight As Long) 
    Dim uMsg As Long 
    If TypeOf ctrl Is ListBox Then 
        uMsg = LB_SETITEMHEIGHT 
    ElseIf TypeOf ctrl Is ComboBox Then 
        uMsg = CB_SETITEMHEIGHT 
    Else 
        Exit Sub 
    End If 
    SendMessage ctrl.hwnd, uMsg, 0, ByVal CLng(newHeight And &HFFFF&) 
    ctrl.Refresh 
End Sub 

Contoh penggunaan:

Private Sub Command1_Click() 
    SetListItemHeight List1, 25 
End Sub 
 
Private Sub Form_Load() 
    Dim i As Integer 
    For i = 1 To 10 
        List1.AddItem i 
    Next 
End Sub 
 

Sehingga hasilnya:

Gambar: Dropdown DataGrid dengan Tinggi Normal

Kemudian: 

Gambar: Dropdown DataGrid dengan Listitem yang Diperbesar (otomatis mengikuti row height datagrid).

READ MORE - VB6 DataGrid: Mengatur Tinggi Listitem Dropdown

VB6 DataGrid: Multiple Delete (Del Key)

Option Explicit 
 
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) 
 
'------------------------------------------------------------------------------- 
'http://khoiriyyah.blogspot.com 
'------------------------------------------------------------------------------- 
 
Dim DontResponseErrorTemporary As Boolean 
 
Private Sub DeleteRows(dtGrid As DataGrid) 
    Dim varBmk As Variant 
    For Each varBmk In dtGrid.SelBookmarks 
        Adodc1.Recordset.Bookmark = varBmk 
        Adodc1.Recordset.Delete 
        Sleep 5 'miliseconds (as delay multiple delete animations) 
        dtGrid.Refresh 
    Next 
End Sub 
 
Private Sub DataGrid1_Error(ByVal DataError As Integer, Response As Integer) 
    If DontResponseErrorTemporary Then 
        Response = 0 
        DontResponseErrorTemporary = False 
    End If 
End Sub 
 
Private Sub DataGrid1_KeyDown(KeyCode As Integer, Shift As Integer) 
    If KeyCode = vbKeyDelete Then 
        If Not DeleteConfirm Then 
            KeyCode = 0 
            Exit Sub 
        End If 
        DontResponseErrorTemporary = True 
        Call DeleteRows(DataGrid1) 
        KeyCode = 0 
    End If 
End Sub 
 
Private Function DeleteConfirm() As Boolean 
    If MsgBox("Are you sure want to delete this record?", vbQuestion + vbYesNo + vbDefaultButton2, "Delete Confirm") = vbYes Then 
        DeleteConfirm = True 
    End If 
End Function 

READ MORE - VB6 DataGrid: Multiple Delete (Del Key)

VB6 DataGrid: Multiple Selection (Left Mouse Down + SHIFT)

Option Explicit 
 
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer 
Private Const VK_SHIFT = &H10 
Private LastRow As Long 
Private SelectionCount As Long 
 
'------------------------------------------------------------------------------- 
'http://khoiriyyah.blogspot.com 
'------------------------------------------------------------------------------- 
 
Private Sub Form_Load() 
    'load database 
    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 
End Sub 
 
Private Sub DataGrid1_SelChange(Cancel As Integer) 
    Call SetSelectionPlusShiftKey(DataGrid1) 
End Sub 
 
Private Sub SetSelectionPlusShiftKey(dtGrid As DataGrid) 
    Dim i As Integer 
    Dim Direction As Integer 
    If GetKeyState(VK_SHIFT) < 0 Then 
        SelectionCount = LastRow - dtGrid.Row 
        If SelectionCount < 0 Then 
            Direction = 1 
        Else 
            Direction = -1 
        End If 
        For i = 0 To SelectionCount Step -Direction 
            DataGrid1.SelBookmarks.Add (dtGrid.GetBookmark(i)) 
        Next i 
    Else 
        LastRow = dtGrid.Row 
    End If 
End Sub 
 
Private Sub Form_Resize() 
    On Error Resume Next 
    DataGrid1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight 
End Sub 

READ MORE - VB6 DataGrid: Multiple Selection (Left Mouse Down + SHIFT)

VB6 DataGrid: Multiple Selection (Mouse Down + Mouse Move)

Option Explicit 
 
Private Declare Function ReleaseCapture Lib "user32.dll" () As Long 
Private Declare Function SetCapture Lib "user32.dll" (ByVal hwnd As Long) As Long 
 
'------------------------------------------------------------------------------- 
'http://khoiriyyah.blogspot.com 
'------------------------------------------------------------------------------- 
 
Dim BeginSelect As Boolean 
Dim CurrentRowY As Long 
 
Private Sub DataGrid1_Click() 
    BeginSelect = False 
    ReleaseCapture 
End Sub 
 
Private Sub Form_Load() 
    'load database 
    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 
End Sub 
 
Private Sub RemoveAllSelected() 
    Dim h As Integer 
    Dim i As Integer 
    h = DataGrid1.SelBookmarks.Count 
    If h = 0 Then Exit Sub 
    For i = h - 1 To 0 Step -1 
        DataGrid1.SelBookmarks.Remove i 
    Next i 
End Sub 
 
Private Sub DataGrid1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    Static t As Integer 
    Dim Direction As Integer 
    Dim i As Integer 
    If BeginSelect Then 
        SetCapture DataGrid1.hwnd 
        If CurrentRowY > DataGrid1.RowContaining(Y) Then 
            Direction = 1 
        Else 
            Direction = -1 
        End If 
        RemoveAllSelected 
        For i = CurrentRowY To DataGrid1.RowContaining(Y) Step -Direction 
            If i = -1 Then 
                Exit For 
            End If 
            DataGrid1.SelBookmarks.Add DataGrid1.RowBookmark(i) 
        Next 
    End If 
End Sub 
 
Private Sub DataGrid1_SelChange(Cancel As Integer) 
    If BeginSelect = False Then 
        Debug.Print DataGrid1.Col 
        CurrentRowY = DataGrid1.Row 
    End If 
    BeginSelect = True 
End Sub 
 
Private Sub Form_Resize() 
    On Error Resume Next 
    DataGrid1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight 
End Sub 
 
Private Sub ReleaseSelect() 
    BeginSelect = False 
    ReleaseCapture 
End Sub 

READ MORE - VB6 DataGrid: Multiple Selection (Mouse Down + Mouse Move)

VB6 DataGrid - Auto Height DropDown DataGrid

Dengan mengetahui tinggi item sebuah ListBox seperti yang telah dijelaskan pada posting sebelumnya, maka ada banyak sekali variant code yang bermanfaat yang bisa dikembangkan, salah satunya adalah mengatur tinggi dropdown datagrid secara otomatis. Hal ini sebenarnya bukan masalah apabila item yang terdapat pada ListBox jumlahnya tetap Anda dapat mengatur tinggi ListBoxnya secara manual, tetapi bagaimana jika dinamis? terkadang 1 item, 2 item, 5 item, dsb.  Jangan sampai terjadi seperti gambar di bawah ini:

Gambar - DropDown DataGrid tanpa Auto Heigh

Padahal tinggi DropDown ListBox seharusnya seperti gambar di bawah ini:

Gambar - DropDown DataGrid dengan Auto Height

Option Explicit 
 
'------------------------------------------------------------------------------------------ '
'http://khoiriyyah.blogspot.com 
'------------------------------------------------------------------------------------------  
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long 
Private Const LB_GETITEMRECT As Long = &H198 
 
Private Type RECT 
    Left As Long 
    Top As Long 
    Right As Long 
    Bottom As Long 
End Type 
 
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long 
 
Private Const SM_CXBORDER = 5 'flat 
Private Const SM_CYBORDER = 6 'flat  
Private Const SM_CXEDGE = 45 '3D 
Private Const SM_CYEDGE = 46 '3D   
  
Private Function ListBoxItemHeight(lst As ListBox) As Integer 
    Dim rc As RECT, I As Long, dy As Long 
    If lst.ListCount = 0 Then Exit Function 
    SendMessage lst.hWnd, LB_GETITEMRECT, ByVal 0&, rc 
    dy = rc.Bottom - rc.Top 
    ListBoxItemHeight = (dy * Screen.TwipsPerPixelY) 
End Function 
 
Private Sub cmdTest_Click() 
    List1.Visible = False 
    List1.AddItem "A" 
    Dim BorderHeight As Integer 
    If List1.ListCount > 8 Then 
        List1.Visible = True 
        Exit Sub 
    End If 
    If List1.Appearance = 0 Then 'flat         
        BorderHeight = (GetSystemMetrics(SM_CXBORDER) * Screen.TwipsPerPixelX) + (GetSystemMetrics(SM_CYBORDER) * Screen.TwipsPerPixelY) 
    ElseIf List1.Appearance = 1 Then '3D         
        BorderHeight = (GetSystemMetrics(SM_CXEDGE) * Screen.TwipsPerPixelX) + (GetSystemMetrics(SM_CYEDGE) * Screen.TwipsPerPixelY) 
    End If 
    List1.Height = (ListBoxItemHeight(List1) * List1.ListCount) + BorderHeight 
    Debug.Print ListBoxItemHeight(List1) 
    Debug.Print List1.Height 
    List1.Visible = True 
End Sub 

READ MORE - VB6 DataGrid - Auto Height DropDown DataGrid