WPFとVB.NET、マウスドラッグ移動で範囲選択、枠表示して枠内のものを取得

マウスドラッグ移動で四角枠を表示して枠内のThumbを取得

デザイン画面とXAML

f:id:gogowaten:20191030122255p:plain

マウスの位置を取得するには背景色を指定する必要があるみたい

だけど色はいらないので透明色のTransparenを指定している

VBコード

f:id:gogowaten:20191030122423p:plain

Imports System.Windows.Controls.Primitives

Class MainWindow
    Private syoki As Point '選択範囲枠の初期位置記録用
    Private IsDrag As Boolean 'canvas1上でマウスドラッグ移動判定用
    Private waku As Path '選択範囲枠
    Private tList As New List(Of Thumb) 'すべてのThumbを入れておくリスト

    '渡されたThumbを指定された位置に移動
    Private Sub SetLocate(ele As UIElement, p As Point)
        Canvas.SetLeft(ele, p.X)
        Canvas.SetTop(ele, p.Y)
    End Sub

    '渡されたThumbの位置を返す
    Private Function GetLocate(ele As UIElement) As Point
        Dim x As Double = Canvas.GetLeft(ele)
        Dim y As Double = Canvas.GetTop(ele)
        Return New Point(x, y)
    End Function

    'Thumbのドラッグ移動用
    Private Sub DragDelta(sender As Object, e As DragDeltaEventArgs)
        Dim t As Thumb = DirectCast(sender, Thumb)
        Dim p As Point = GetLocate(t)
        Dim nx As Double = e.HorizontalChange + p.X
        Dim ny As Double = e.VerticalChange + p.Y
        nx = nx - (nx Mod 20)
        ny = ny - (ny Mod 20)
        SetLocate(t, New Point(nx, ny))
    End Sub

    'Thumbを10個作成
    Private Sub AddThumb()
        Dim t As Thumb
        For i As Integer = 0 To 9
            t = New Thumb With {
                .Width = 60, .Height = 60, .Background = Brushes.Aqua}
            Canvas.SetLeft(t, i * 20) : Canvas.SetTop(t, i * 20 + 20)
            AddHandler t.DragDelta, AddressOf DragDelta
            tList.Add(t)
            canvas1.Children.Add(t)
        Next
    End Sub




    '選択範囲内のThumbの色を赤に変える
    'RectクラスのIntersectsWithメソッドを使う
    Private Sub SelectThumb()
        Dim sr As Rect = waku.Data.Bounds '枠のRect
        Dim tr As Rect
        For Each t As Thumb In tList
            tr = New Rect(GetLocate(t), t.RenderSize) 'ThumbのRect
            'ThumbのRectが枠のRectと重なっているか判定
            If tr.IntersectsWith(sr) Then
                '重なっていたら赤
                t.Background = Brushes.Red
            End If
        Next
    End Sub


    '選択範囲枠用のPathデータ作成
    Private Sub SetPathData(p As Point)
        Dim r As New Rect(syoki, p)
        Dim gp As New RectangleGeometry(r)
        waku.Data = gp
    End Sub

    'アプリ起動中
    Private Sub MainWindow_Initialized(sender As Object, e As EventArgs) Handles Me.Initialized
        Call AddThumb() 'Thumbを作成
    End Sub

    'アプリ起動完了後
    Private Sub MainWindow_ContentRendered(sender As Object, e As EventArgs) Handles Me.ContentRendered
        '範囲選択枠の設定
        waku = New Path With {.Stroke = Brushes.Red, .StrokeThickness = 1.0R}
    End Sub

    'canvas1上で左クリック時
    Private Sub canvas1_MouseLeftButtonDown(sender As Object, e As MouseButtonEventArgs) Handles canvas1.MouseLeftButtonDown
        Dim c As Canvas = DirectCast(sender, Canvas)
        syoki = e.GetPosition(c)
        c.CaptureMouse()
        waku.Data = New RectangleGeometry() '枠データの初期化
        canvas1.Children.Add(waku)
        IsDrag = True
    End Sub

    'canvas1上でマウス移動時
    Private Sub canvas1_MouseMove(sender As Object, e As MouseEventArgs) Handles canvas1.MouseMove
        If IsDrag = False Then Return
        Dim imap As Point = e.GetPosition(canvas1)
        Call SetPathData(imap) '範囲選択枠データの更新
    End Sub

    'canvas1上で左クリック離した時
    Private Sub canvas1_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles canvas1.MouseLeftButtonUp
        If IsDrag = False Then Return
        Call SelectThumb() '選択範囲内のThumbを赤にする
        Dim c As Canvas = DirectCast(sender, Canvas)
        IsDrag = False
        c.ReleaseMouseCapture()
        canvas1.Children.Remove(waku) '選択範囲枠の消去
    End Sub

    'Thumbの色を初期化、アクアにする
    Private Sub bt1_Click(sender As Object, e As RoutedEventArgs) Handles bt1.Click
        For i As Integer = 0 To tList.Count - 1
            tList(i).Background = Brushes.Aqua
        Next
    End Sub
End Class