Showing posts with label Mouse. Show all posts
Showing posts with label Mouse. 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

Sunday, June 17, 2012

Aplikasi Untuk Melihat Warna Yang Ada Di bawah Pointer

'simpan kode di bawah pada module
Option Explicit

Private Declare Function CreateDC& Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any)
Private Declare Function DeleteDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Private Type POINTAPI
X As Long
Y As Long
End Type

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'simpan kode di bawah pada form
'Timer.Interval = 1
'Picture1.AutoRedraw = True

'Option Explicit

Dim pt As POINTAPI

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Timer1.Enabled = True
Picture1.MousePointer = vbCrosshair
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Timer1.Enabled = False
Picture1.MousePointer = vbDefault
End Sub

Private Sub Timer1_Timer()
Dim screendc As Long
GetCursorPos pt
screendc = CreateDC("DISPLAY", "", "", 0&)
Picture1.BackColor = GetPixel(screendc, pt.X, pt.Y)
Text1.Text = "#" & Hex(GetPixel(screendc, pt.X, pt.Y))
DeleteDC (screendc)
End Sub
READ MORE - Aplikasi Untuk Melihat Warna Yang Ada Di bawah Pointer

Friday, June 8, 2012

Menonaktifkan Keyboard dan Mouse - BlockInput

Option Explicit 

Private Declare Function
BlockInput Lib "user32" (ByVal fBlock As Long) As Long

Private Sub
Command1_Click()
Timer1.Enabled = True
BlockInput True
End Sub

'Gunakan kode di bawah, agar komputer Anda tidak usah di restart
Private Sub Form_Load()
Timer1.Interval = 1000 '1 detik
Timer1.Enabled = False
End Sub

'Timer1.Interval = 1000 '1 detik
Private Sub Timer1_Timer()
Static i As Integer
i = i +
1
If i > 5 Then 'tunggu 5 detik
BlockInput False 'aktifkan kembali keyboard dan mouse
i = 0
End If
End Sub
READ MORE - Menonaktifkan Keyboard dan Mouse - BlockInput

Mouse Properties Dialog, Bagaimana Cara Menampilkannya?

Di bawah merupakan kode untuk menampilkan mouse properties dialog menggunakan VB6 (Visual Basic 6) - Bagaimana menampilkan mouse properties dialog ini, bisa Anda lihat di bawah:
Option Explicit 

Private Sub
Command1_Click()
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", 5)
End Sub
READ MORE - Mouse Properties Dialog, Bagaimana Cara Menampilkannya?

Memeriksa Apakah Pointer Mouse Masuk Di atas Sebuah Objek

Menjelaskan mengenai cara untuk memeriksa apakah pointer/cursor mouse berada di atas sebuah objek - Terkadang kita memerlukan sebuah kode untuk memeriksa apakah cursor atau pointer berada di atas sebuah objek, misalnya untuk keperluan hover, dsb. Untuk kasus objek yang memiliki property .hwnd hal tersebut mudah sekali dilakukan yaitu dengan memanggil fungsi API SetCapture dan ReleaseCapture, tapi bagaimana jika objek tersebut tidak memiliki property .hwnd, misalnya objek label atau image?

Di bawah ini merupakan module untuk memeriksa apakah pointer atau cursor berada di atas sebuah objek, untuk mengujinya sediakan 1 Timer dengan property Name = tmrInBox, kemudian 1 PictureBox dengan properpty Name = Picture1 (default).
'simpan kode di bawah pada sebuah module 
Option Explicit

Private Declare Function
ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function
GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Type
POINTAPI
x As Long
y As Long
End Type

Public Function
InBox(ctl As Control) As Boolean
Dim pt As
POINTAPI
GetCursorPos pt
ScreenToClient ctl.Parent.hwnd, pt
InBox = Not (pt.x < ctl.Left Or pt.y < ctl.Top Or pt.x > ctl.Left + ctl.Width Or pt.y > ctl.Top + ctl.Height)
End Function

'simpan kode di bawah pada form 
Option Explicit

Dim
blnFlag As Boolean

Private Sub
Form_Load()
Form1.ScaleMode = vbPixels 'pixels units
tmrInBox.Interval = 10 'or 1 if posible
End Sub

Private Sub
tmrInBox_Timer()
If Not InBox(Picture1) Then
blnFlag = False
tmrInBox.Enabled = False
Picture1.BackColor = vbBlack
End If
End Sub

Private Sub
Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If blnFlag Then Exit Sub
blnFlag = True
tmrInBox.Enabled = True
Picture1.BackColor = vbWhite
End Sub
READ MORE - Memeriksa Apakah Pointer Mouse Masuk Di atas Sebuah Objek

Monday, May 28, 2012

Memperoleh Waktu Double Klik Pada Mouse

Source di bawah ini berguna untuk memperoleh waktu double klik pada mouse dengan menggunakan fungsi API GetDoubleClick.
Option Explicit 

Private Declare Function
GetDoubleClickTime Lib "user32" () As Long

Private Sub
Command1_Click()
Dim ret As Long
ret = GetDoubleClickTime
Text1.Text = ret & " milliseconds"
End Sub
READ MORE - Memperoleh Waktu Double Klik Pada Mouse

Sunday, May 27, 2012

Merubah Waktu Double Klik Pada Mouse

Di bawah ini merupakan fungsi untuk merubah waktu double klik pada mouse. Bagaimana implementasinya dalam Visual Basic 6.0? Simaklah kodenya di bawah ini.
Option Explicit 

Private Declare Function
SetDoubleClickTime Lib "user32" (ByVal wCount As Long) As Long

Public Function
ChangeDBClkTime(Time As Integer)
SetDoubleClickTime (Time)
End Function
Contoh penggunaan:
Private Sub Command1_Click() 
Call ChangeDBClkTime(1000)
End Sub
READ MORE - Merubah Waktu Double Klik Pada Mouse

Memeriksa Apakah Mouse Terinstall Pada Komputer Anda

Di bawah ini merupakan fungsi untuk memeriksa apakah mouse terinstall pada komputer Anda. Bagaimana implementasinya dalam Visual Basic 6.0? simaklah kodenya di bawah ini.
Option Explicit 

Private Const
SM_CMOUSEBUTTONS = 43
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Public Function
IsMousePresent() As Boolean
IsMousePresent = (GetSystemMetrics(SM_CMOUSEBUTTONS) > 0)
End Function
Contoh penggunaan:
Private Sub Command1_Click() 
MsgBox IsMousePresent
End Sub
READ MORE - Memeriksa Apakah Mouse Terinstall Pada Komputer Anda

Memperoleh Jumlah Tombol Yang Terdapat Pada Mouse

Di bawah ini merupakan fungsi untuk mengetahui jumlah tombol yang terdapat pada mouse.
Option Explicit 

Private Declare Function
GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const
SM_CMOUSEBUTTONS As Long = 43

Public Function
ButtonMouse()
ButtonMouse = GetSystemMetrics(SM_CMOUSEBUTTONS)
End Function
Contoh penggunaan:
Private Sub Command1_Click() 
MsgBox ButtonMouse
End Sub
READ MORE - Memperoleh Jumlah Tombol Yang Terdapat Pada Mouse

Menyembunyikan dan Menampilkan Pointer Mouse

Di bawah ini merupakan procedure untuk menyembunyikan dan menampilkan pointer mouse. Bagaimana implementasinya dalam Visual Basic 6.0, simaklah kodenya di bawah ini:
Option Explicit 

Private Declare Function
ShowCursor Lib &amp;amp;amp;quot;user32&amp;amp;amp;quot; ByVal bShow As Long) As Long

Sub
ShowMouseCursor(bShow As Boolean)
ShowCursor bShow
End Sub
Dua contoh penggunaan menyembunyikan dan menampilkan pointer mouse
Private Sub Check1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
ShowMouseCursor Check1.Value = 0)
End Sub

Private Sub
Command1_Click()
ShowMouseCursor True
End Sub
READ MORE - Menyembunyikan dan Menampilkan Pointer Mouse

Menggerakan Pointer Mouse Pada Koordinat Tertentu

Di bawah ini merupakan fungsi untuk menggerakan pointer mouse pada koordinat tertentu.
Private Declare Function SetCursorPos Lib "User32" ByVal X As Long, ByVal Y As Long) As Long 
'Contoh penggunaan code untuk menggerakan pointer mouse pada koordinat tertentu
Private Sub Command1_Click()
Call SetCursorPos(100, 200)
End Sub
READ MORE - Menggerakan Pointer Mouse Pada Koordinat Tertentu

Menukarkan Tombol Mouse

Di bawah ini merupakan procedure untuk menukarkan tombol mouse, dari kiri ke kanan dan sebaliknya. Bagaimana implementasinya dalam Visual Basic 6.0, simaklah kodenya di bawah ini:
Option Explicit 

Private Declare Function
SwapMouseButton Lib "user32" (ByVal bSwap As Long) As Long

Public Sub
SwapMouse(bSwap As Boolean)
SwapMouseButton bSwap
End Sub
Dua contoh penggunaan menukarkan tombol mouse
Private Sub Check1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
SwapMouse (Check1.Value=0)
End Sub

Private Sub
Command1_Click()
SwapMouse True
End Sub
READ MORE - Menukarkan Tombol Mouse

Sunday, April 4, 2010

VB6 Code - Memperoleh Waktu Double Klik Pada Mouse

Source code VB6 di bawah ini berguna untuk memperoleh waktu double klik pada mouse dengan menggunakan fungsi API GetDoubleClick.
Option Explicit

Private Declare Function GetDoubleClickTime Lib "user32" () As Long

Private Sub Command1_Click()
Dim ret As Long
ret = GetDoubleClickTime
Text1.Text = ret & " milliseconds"
End Sub
READ MORE - VB6 Code - Memperoleh Waktu Double Klik Pada Mouse

Saturday, April 3, 2010

VB6 Code - Mengetahui Jumlah Tombol Yang Terdapat Pada Mouse

Di bawah ini merupakan fungsi VB6 untuk mengetahui jumlah tombol yang terdapat pada mouse.
Option Explicit

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CMOUSEBUTTONS As Long = 43

Public Function ButtonMouse()
ButtonMouse = GetSystemMetrics(SM_CMOUSEBUTTONS)
End Function
Contoh penggunaan fungsi VB6 di atas:
Private Sub Command1_Click()
MsgBox ButtonMouse
End Sub
READ MORE - VB6 Code - Mengetahui Jumlah Tombol Yang Terdapat Pada Mouse

VB6 Code - Apakah Mouse Terinstall Pada Komputer Anda?

Di bawah ini merupakan fungsi VB6 untuk memeriksa apakah mouse terinstall pada komputer Anda. Bagaimana implementasinya dalam Visual Basic 6.0? simaklah kodenya di bawah ini.
Option Explicit

Private Const SM_CMOUSEBUTTONS = 43
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Public Function IsMousePresent() As Boolean
IsMousePresent = (GetSystemMetrics(SM_CMOUSEBUTTONS) > 0)
End Function
Contoh penggunaan fungsi VB6 di atas:
Private Sub Command1_Click()
MsgBox IsMousePresent
End Sub
READ MORE - VB6 Code - Apakah Mouse Terinstall Pada Komputer Anda?

VB6 Code - Merubah Waktu Double Klik Pada Mouse

Di bawah ini merupakan fungsi VB6 untuk merubah waktu double klik pada mouse. Bagaimana implementasinya dalam Visual Basic 6.0? Simaklah kodenya di bawah ini.
Option Explicit

Private Declare Function SetDoubleClickTime Lib "user32" (ByVal wCount As Long) As Long

Public Function ChangeDBClkTime(Time As Integer)
SetDoubleClickTime (Time)
End Function
Contoh penggunaan fungsi VB6 di atas:
Private Sub Command1_Click()
Call ChangeDBClkTime(1000)
End Sub
READ MORE - VB6 Code - Merubah Waktu Double Klik Pada Mouse

VB6 Code - Menyembunyikan Dan Menampilkan Pointer Mouse

Di bawah ini merupakan procedure VB6 untuk menyembunyikan dan menampilkan pointer mouse. Bagaimana implementasinya dalam Visual Basic 6.0, simaklah kodenya di bawah ini:
Option Explicit

Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

Sub ShowMouseCursor(bShow As Boolean)
ShowCursor bShow
End Sub
Dua contoh penggunaan menyembunyikan dan menampilkan pointer mouse
Private Sub Check1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
ShowMouseCursor (Check1.Value = 0)
End Sub

Private Sub Command1_Click()
ShowMouseCursor True
End Sub

READ MORE - VB6 Code - Menyembunyikan Dan Menampilkan Pointer Mouse

VB6 Code - Procedure Membatasi Pointer Mouse

Di bawah ini merupakan procedure VB6 untuk membatasi gerak pointer mouse pada objek tertentu yang memilliki hwnd (handle window).
Option Explicit

Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT)
Private Declare Sub ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINT)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long)

Private Type RECT
left As Integer
top As Integer
right As Integer
bottom As Integer
End Type

Private Type POINT
x As Long
y As Long
End Type

Public Sub LimitCursorMovement(ctl As Object)

Dim client As RECT
Dim upperleft As POINT
Dim lHwnd As Long

On Error Resume Next

lHwnd = ctl.hWnd
If lHwnd = 0 Then Exit Sub

GetClientRect ctl.hWnd, client
upperleft.x = client.left
upperleft.y = client.top
ClientToScreen ctl.hWnd, upperleft
OffsetRect client, upperleft.x, upperleft.y
ClipCursor client

End Sub

Public Sub ReleaseLimit()
ClipCursor ByVal 0&
End Sub
Contoh penggunaan procedureVB6  membatasi pointer mouse
Private Sub Command1_Click()
Command1.Caption = IIf(Command1.Caption = "Set Limit", "Release", "Set Limit")
If Command1.Caption = "Set Limit" Then
ReleaseLimit
Else
LimitCursorMovement Command1
End If
End Sub

Private Sub Form_Load()
Command1.Caption = "Set Limit"
End Sub
READ MORE - VB6 Code - Procedure Membatasi Pointer Mouse

VB Code - Menukarkan Tombol Mouse

Di bawah ini merupakan procedure VB6 untuk menukarkan tombol mouse, dari kiri ke kanan dan sebaliknya. Bagaimana implementasinya dalam Visual Basic 6.0, simaklah kodenya di bawah ini:
Option Explicit

Private Declare Function SwapMouseButton Lib "user32" (ByVal bSwap As Long) As Long

Public Sub SwapMouse(bSwap As Boolean)
SwapMouseButton bSwap
End Sub
Dua contoh penggunaan menukarkan tombol mouse
Private Sub Check1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
SwapMouse (Check1.Value=0)
End Sub

Private Sub Command1_Click()
SwapMouse True
End Sub
READ MORE - VB Code - Menukarkan Tombol Mouse

VB6 Code - Menggerakan Pointer Mouse Satu Koordinat

Di bawah ini merupakan fungsi VB6 untuk menggerakan pointer mouse pada koordinat tertentu.
Private Declare Function SetCursorPos Lib "User32" (ByVal X As Long, ByVal Y As Long) As Long
Contoh penggunaan code untuk menggerakan pointer mouse pada koordinat tertentu
Private Sub Command1_Click()
Call SetCursorPos(100, 200)
End Sub
READ MORE - VB6 Code - Menggerakan Pointer Mouse Satu Koordinat