|
サンプル投下しておきます。
Imports System.Runtime.InteropServices
Public Class TrackBarEx
Inherits TrackBar
'**********************************************************************
' マウスの処理
'**********************************************************************
Private _IsDragging As Boolean
Private _DragStartValue As Integer
Private ReadOnly Property ChannelRectangle As Rectangle
Get
Dim rc As RECT = New RECT()
SendMessage(Handle, TBM_GETCHANNELRECT, IntPtr.Zero, rc)
Return rc.ToRectangle()
End Get
End Property
Private ReadOnly Property SliderRectangle As Rectangle
Get
Dim rc As RECT = New RECT()
SendMessage(Handle, TBM_GETTHUMBRECT, IntPtr.Zero, rc)
Return rc.ToRectangle()
End Get
End Property
Protected Overrides Sub WndProc(ByRef m As Message)
Select Case m.Msg
Case WM_LBUTTONDOWN
WmLButtonDown(m)
Case WM_LBUTTONUP
WmLButtonUp(m)
Case Else
MyBase.WndProc(m)
End Select
End Sub
Private Sub WmLButtonDown(ByRef m As Message)
Dim pt As Point = GetMousePoint(m)
If SliderRectangle.Contains(pt) Then
_IsDragging = True
_DragStartValue = Value
MyBase.WndProc(m)
Else
'MyBase.WndProc(m)を呼ばないがイベントは起こす
MyBase.OnMouseDown(New MouseEventArgs(MouseButtons.Left, 1, pt.X, pt.Y, 0))
End If
End Sub
Private Sub WmLButtonUp(ByRef m As Message)
If _IsDragging Then
_IsDragging = False
If _DragStartValue <> Value Then
MyBase.OnValueChanged(EventArgs.Empty)
End If
Else
Dim pt As Point = GetMousePoint(m)
If ClientRectangle.Contains(pt) Then
Dim channel As Rectangle = Me.ChannelRectangle
Select Case pt.X
Case < channel.Left
Value = Minimum
Case channel.Left To channel.Right
Dim ratio As Double = CDbl(pt.X - channel.Left) / CDbl(channel.Width)
Value = CInt(ratio * (Maximum - Minimum)) + Minimum
Case Else
Value = Maximum
End Select
End If
End If
MyBase.WndProc(m)
End Sub
Protected Overrides Sub OnValueChanged(e As EventArgs)
If Not _IsDragging Then
MyBase.OnValueChanged(e)
End If
End Sub
'**********************************************************************
' キーのリピート禁止
'**********************************************************************
Private ReadOnly _IsKeyDowns As New Dictionary(Of Keys, Boolean)
Protected Overrides Sub OnKeyDown(e As KeyEventArgs)
MyBase.OnKeyDown(e)
Dim state As Boolean
If Not _IsKeyDowns.TryGetValue(e.KeyCode, state) Then
state = False
End If
e.Handled = state
_IsKeyDowns(e.KeyCode) = True
End Sub
Protected Overrides Sub OnKeyUp(e As KeyEventArgs)
MyBase.OnKeyUp(e)
_IsKeyDowns(e.KeyCode) = False
End Sub
'**********************************************************************
' 定数/関数
'**********************************************************************
Private Const WM_LBUTTONDOWN As Integer = &H201
Private Const WM_LBUTTONUP As Integer = &H202
Private Const WM_USER As Integer = &H400
Private Const TBM_GETTHUMBRECT As Integer = WM_USER + 25
Private Const TBM_GETCHANNELRECT As Integer = WM_USER + 26
Private Structure RECT
Public left, top, right, bottom As Integer
Public Function ToRectangle() As Rectangle
Return Rectangle.FromLTRB(left, top, right, bottom)
End Function
End Structure
<DllImport("user32.dll", CharSet:=CharSet.Auto)>
Private Shared Function SendMessage(ByVal hWnd As IntPtr,
ByVal msg As Integer,
ByVal wp As IntPtr,
ByRef lp As RECT) As IntPtr
End Function
Private Shared Function GetMousePoint(ByRef m As Message) As Point
Dim x As Integer = SignedLOWORD(m.LParam)
Dim y As Integer = SignedHIWORD(m.LParam)
Return New Point(x, y)
End Function
Private Shared Function SignedHIWORD(ByVal n As IntPtr) As Integer
Dim tmp As Byte() = BitConverter.GetBytes(n.ToInt64())
Return SignedHIWORD(BitConverter.ToInt32(tmp, 0))
End Function
Private Shared Function SignedHIWORD(ByVal n As Integer) As Integer
Dim tmp As Byte() = BitConverter.GetBytes(n >> 16 And &HFFFF)
Return BitConverter.ToInt16(tmp, 0)
End Function
Private Shared Function SignedLOWORD(ByVal n As IntPtr) As Integer
Dim tmp As Byte() = BitConverter.GetBytes(n.ToInt64())
Return SignedLOWORD(BitConverter.ToInt32(tmp, 0))
End Function
Private Shared Function SignedLOWORD(ByVal n As Integer) As Integer
Dim tmp As Byte() = BitConverter.GetBytes(n And &HFFFF)
Return BitConverter.ToInt16(tmp, 0)
End Function
End Class
|