C# と VB.NET の質問掲示板

ASP.NET、C++/CLI、Java 何でもどうぞ

C# と VB.NET の入門サイト

TrackBarでスライダーがカーソルに付いてくる

[トピック内 2 記事 (1 - 2 表示)]  << 0 >>

■93044 / inTopicNo.1)  TrackBarでスライダーがカーソルに付いてくる
  
□投稿者/ 小次郎 (10回)-(2019/11/16(Sat) 15:16:09)

分類:[.NET 全般] 

http://bbs.wankuma.com/index.cgi

このページの関連質問です。

このページの方法で、TrackBarをクリックした時に
その場所にスライダーが動くようにしました。

一つ問題は、クリックしてスライダーを動かした後に、
カーソルを動かすと、既にマウスのボタンを離しているにも拘わらず
カーソルに向かってスライダーが動いてくるという現象が発生しています。

二つプログラムがあり、

Private Sub TrackBar1_ValueChanged(sender As Object, e As EventArgs) Handles TrackBar1.ValueChanged

' 計算処理

End Sub


これの計算処理が軽い場合にはこの現象は起きていません。


Protected Overrides Sub WndProc(ByRef m As Message)
If m.Msg = &H200 OrElse m.Msg = &H2A1 Then ' WM_MOUSEMOVE message WM_MOUSEHOVER

m.Result = IntPtr.Zero
Return
End If
MyBase.WndProc(m)
End Sub

のようにして、MouseMoveとMouseHoverを抑止してみたのですが、
それでもやはりこの現象は止まりません。
別のコントロールをクリックすると止まるため、




Private Sub TrackBar1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles TrackBar1.MouseDown

Me.ActiveControl = Nothing

End Sub

としてみたのですが、駄目でした。

また、Trackbar上でミドルクリックしても止まるため



Call mouse_event(MOUSEEVENTF_MIDDLEDOWN, e.X, e.Y, 0, 0)

を入れてみたのですが、
なぜかプログラムがバグってしまい、マウスクリックが効かなくなります。

一体どうすれば良いでしょうか?
引用返信 編集キー/
■93078 / inTopicNo.2)  Re[1]: TrackBarでスライダーがカーソルに付いてくる
□投稿者/ KOZ (41回)-(2019/11/18(Mon) 23:45:14)
サンプル投下しておきます。

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


引用返信 編集キー/

このトピックをツリーで一括表示


トピック内ページ移動 / << 0 >>

このトピックに書きこむ