午後わてんのブログ

ベランダ菜園とWindows用アプリ作成(WPFとC#)

WPF、変形後の要素(Thumb)のグリッドスナップ移動

 

gogowaten.hatenablog.com

前回で要素の変形後の位置とサイズを取得できるようになったので、それを使って目的だった変形後のグリッドスナップ移動ができるようなった
 
今回のアプリのダウンロード先

github.com

 

コードは

github.com

 

グリッドスナップ移動
イメージ 2
橙色の四角要素をグリッド(水色罫線)に合わせて移動するとき
左上をグリッドに合わせて移動するようにしたい
要素を回転(変形)させるといろいろな左上ができる
回転後のいろいろな左上
イメージ 1
赤枠、青枠はただの目印
赤枠は回転前の位置とサイズ
青枠は回転後の要素がピッタリ収まる位置とサイズ
この2つの枠の左上が赤青矢印の先と
元の左上が回転で移動した橙色矢印の先
この3つを切り替えてスナップ移動
 
イメージ 3
できた!
見てて思ったのが赤枠基準はいらないかなあってのと
シングルクリックがダブルクリックになったり
マウスドッラグ中にクリックになったりしない、そんな
マウスがほしい
 
 
デザイン画面とXAMLXAMLを書くと投稿エラーになるから画像で表示するのです

f:id:gogowaten:20191031143423p:plain

 
 
VBコード
Imports System.ComponentModel
Imports System.Globalization
Imports System.Windows.Controls.Primitives

Class MainWindow
    Private WithEvents MyExThumb As ExThumb
   'Canvasにグリッド(罫線)表示
    Private Sub SetGridLine()
        Dim gSize As Integer = sldGrid.Value
        Dim w As Double = MyCanvas.Width
        Dim h As Double = MyCanvas.Height
        Dim whMax As Integer = IIf(w > h, w, h)
        Dim pFigure As PathFigure
        Dim pGeometry As New PathGeometry

        For i As Integer = 0 To whMax / gSize
           '横線
            pFigure = New PathFigure With {.StartPoint = New Point(0, i * gSize)}
            pFigure.Segments.Add(New LineSegment(New Point(whMax, i * gSize), True))
            pGeometry.Figures.Add(pFigure)
           '縦線
            pFigure = New PathFigure With {.StartPoint = New Point(i * gSize, 0)}
            pFigure.Segments.Add(New LineSegment(New Point(i * gSize, whMax), True))
            pGeometry.Figures.Add(pFigure)
        Next

        With GridLine
            .Data = pGeometry
            .Stroke = Brushes.Cyan
            .StrokeThickness = 2.0
        End With
    End Sub
    Private Sub MyCheck()
        Dim d = 119 \ 10
        Dim root = MyExThumb.testRootCanvas
    End Sub
    Private Sub MyCheck2()
        MyExThumb.SetPoint2(100, 100)
    End Sub
    Private Sub MyMove()
        MyExThumb.MyLeft = 100
        MyExThumb.MyTop = 100
    End Sub
   '数値確認用のTextBlockへのBinding
    Private Sub SetTextBlockBinding(so As Object, sName As String, tb As TextBlock)
        Dim b As New Binding(sName) With {.Source = so, .StringFormat = sName & " = {0:0.0}"}
        tb.SetBinding(TextBlock.TextProperty, b)
    End Sub
    Private Sub MainWindow_Initialized(sender As Object, e As EventArgs) Handles Me.Initialized
       'グリッドサイズ指定
        sldGrid.Value = 30
       'グリッド罫線表示
        Call SetGridLine()

        AddHandler btnCheck.Click, AddressOf MyCheck
        AddHandler btn2.Click, AddressOf MyCheck2
        AddHandler btn4.Click, AddressOf MyMove
        AddHandler sldGrid.ValueChanged, AddressOf SetGridLine 'スライダーの値変更でグリッド(罫線)の表示更新

       'ExThumbに100x100の赤Borderを追加してMyCanvasに表示
        Dim ext As New ExThumb(New Border With {
                               .Width = 100, .Height = 100, .Background = Brushes.Orange, .Opacity = 0.5})
        Canvas.SetLeft(ext, 0) : Canvas.SetTop(ext, 0)
        MyCanvas.Children.Add(ext)
        MyExThumb = ext

       '回転角度をSliderにBinding
        Dim b As Binding
        b = New Binding(NameOf(ExThumb.MyAngle)) With {.Source = MyExThumb, .Mode = BindingMode.TwoWay}
        sldAngle.SetBinding(Slider.ValueProperty, b)

       '数値確認用のTextBlockへのBinding
        Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyAngle), tbAngle) '角度
        Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyDiffPoint), tbRect) '差分座標
        Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyLeft), tbLeft) '実際のX座標
        Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyOutBounds), tbBounds) '見た目のピッタリ枠
        Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyTop), tbTop)
        Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyTransformedTopLeft), tbTTopLeft)

       '目印の青枠
       'ぴったり枠のRectを青枠のDataにバインディング
       '値はRectからRectangleGeometryに変換する必要があるのでコンバータ使用
        b = New Binding(NameOf(ExThumb.MyOutBounds)) With {.Source = MyExThumb, .Converter = New MyConverterRect}
        pathRect.SetBinding(Path.DataProperty, b)

    End Sub
   'マウスドラッグ移動
    Private Sub MyExThumb_DragDelta(sender As Object, e As DragDeltaEventArgs) Handles MyExThumb.DragDelta
        Dim GridSize As Integer = sldGrid.Value
       ''通常移動
       'MyExThumb.MyLeft += e.HorizontalChange
       'MyExThumb.MyTop += e.VerticalChange

       'グリッドスナップ移動
        Dim x, y As Double
        Dim xx, yy, xxx, yyy As Integer
        Select Case True
            Case rbNormal.IsChecked
               '変形前の左上を基準、赤枠
                With MyExThumb
                    x = .MyLeft + e.HorizontalChange
                    y = .MyTop + e.VerticalChange
                    xx = x \ GridSize : yy = y \ GridSize
                    xxx = xx * GridSize : yyy = yy * GridSize
                    .MyLeft = xxx : .MyTop = yyy
                End With
            Case rbFitFlame.IsChecked
               'ぴったり枠の左上を基準、青枠(OutBounds)
                With MyExThumb
                    x = .MyLeft + e.HorizontalChange + .MyDiffPoint.X
                    y = .MyTop + e.VerticalChange + .MyDiffPoint.Y
                    xx = x \ GridSize : yy = y \ GridSize
                    xxx = xx * GridSize : yyy = yy * GridSize
                    .SetPoint2(xxx, yyy)
                End With
            Case rbTopLeft.IsChecked
               '変形で移動した元左上座標を基準
                With MyExThumb
                    x = .MyLeft + e.HorizontalChange + .MyDiffPointTopLeft.X
                    y = .MyTop + e.VerticalChange + .MyDiffPointTopLeft.Y
                    xx = x \ GridSize : yy = y \ GridSize
                    xxx = xx * GridSize : yyy = yy * GridSize
                    .SetPoint3(xxx, yyy)
                End With
        End Select

       '目印の移動
       '変形で移動した元左上座標
        Canvas.SetLeft(Line1, xxx)
        Canvas.SetTop(Line1, yyy)
       '元の枠、赤枠
        Canvas.SetLeft(InBounds, MyExThumb.MyLeft)
        Canvas.SetTop(InBounds, MyExThumb.MyTop)
    End Sub
   'ドラッグ中はマウスカーソルを手の形に
    Private Sub MyExThumb_DragStarted(sender As Object, e As DragStartedEventArgs) Handles MyExThumb.DragStarted
        MyExThumb.Cursor = Cursors.Hand
    End Sub
   'ドラッグ終了で元のマウスカーソル
    Private Sub MyExThumb_DragCompleted(sender As Object, e As DragCompletedEventArgs) Handles MyExThumb.DragCompleted
        MyExThumb.Cursor = Cursors.Arrow
    End Sub
End Class





Public Class ExThumb
    Inherits Thumb 'Thumbを継承
    Implements ComponentModel.INotifyPropertyChanged '通知プロパティ用
    Private RootCanvas As Canvas
    Private RootRotate As RotateTransform
    Public testRootCanvas As Canvas
   'OutBoundsの左上座標を指定
    Public Sub SetPoint2(x As Double, y As Double)
        MyLeft = x + (-MyDiffPoint.X)
        MyTop = y + (-MyDiffPoint.Y)
    End Sub
    Public Sub SetPoint3(x As Double, y As Double)
        MyLeft = x + (-MyDiffPointTopLeft.X)
        MyTop = y + (-MyDiffPointTopLeft.Y)
    End Sub
   'DiffPointとOutBoundsの更新、変形時に実行する
    Private Sub SetDiffPointAndOutSize()
        Dim gt As GeneralTransform = RootCanvas.TransformToVisual(Me)
        Dim r As Rect = gt.TransformBounds(New Rect(New Size(RootCanvas.Width, RootCanvas.Height)))
        MyDiffPoint = r.Location 'ピッタリ座標
        MyOutSize = r.Size 'ぴったりサイズ
        MyDiffPointTopLeft = gt.Transform(New Point) '元左上差分
        Call SetOutBounds()

       '未使用
        Dim p1 As Point = gt.Transform(New Point) '変形前後の左上座標の差分
        Dim p2 As Point = gt.Transform(New Point(RootCanvas.Width, 0)) '右上
        Dim p3 As Point = gt.Transform(New Point(RootCanvas.Width, RootCanvas.Height)) '右下
        Dim p4 As Point = gt.Transform(New Point(0, RootCanvas.Height)) '左下
    End Sub
   'OutBoundsとTransformedTopLeftの更新、移動時に実行する
    Private Sub SetOutBounds()
       'Dim gt As GeneralTransform = RootCanvas.TransformToVisual(Me)
        Dim r As Rect = New Rect(New Point(MyDiffPoint.X + MyLeft, MyDiffPoint.Y + MyTop), MyOutSize)
        MyOutBounds = r
        Dim p As New Point(MyLeft, MyTop)
        MyTransformedTopLeft = p + MyDiffPointTopLeft
    End Sub



#Region "Property"
    Public Event PropertyChanged As PropertyChangedEventHandler Implements INotifyPropertyChanged.PropertyChanged
    Private Sub NotifyPropertyChanged(<System.Runtime.CompilerServices.CallerMemberName> Optional propertyName As String = Nothing)
        RaiseEvent PropertyChanged(Me, New PropertyChangedEventArgs(propertyName))
    End Sub

   '回転角度
    Private Property _MyAngle As Double
    Public Property MyAngle As Double
        Get
            Return _MyAngle
        End Get
        Set(value As Double)
            If value <> _MyAngle Then
                _MyAngle = value
                RootRotate.Angle = value
                Call NotifyPropertyChanged()
                Call SetDiffPointAndOutSize()
            End If
        End Set
    End Property
   'X座標
    Private Property _MyLeft As Double
    Public Property MyLeft As Double
        Get
            Return _MyLeft
        End Get
        Set(value As Double)
            If value <> _MyLeft Then
                _MyLeft = value
                Canvas.SetLeft(Me, value)
                Call NotifyPropertyChanged()
                Call SetOutBounds()
            End If
        End Set
    End Property
   'Y座標
    Private Property _MyTop As Double
    Public Property MyTop As Double
        Get
            Return _MyTop
        End Get
        Set(value As Double)
            If value <> _MyTop Then
                _MyTop = value
                Canvas.SetTop(Me, value)
                Call NotifyPropertyChanged()
                Call SetOutBounds()
            End If
        End Set
    End Property

   '変形前後のぴったり枠の左上座標の差分
    Private Property _MyDiffPoint As Point
    Public Property MyDiffPoint As Point
        Get
            Return _MyDiffPoint
        End Get
        Set(value As Point)
            _MyDiffPoint = value
            Call NotifyPropertyChanged()
        End Set
    End Property
   '変形後の要素がピッタリ収まるサイズ
    Private Property _MyOutSize As Size
    Public Property MyOutSize As Size
        Get
            Return _MyOutSize
        End Get
        Set(value As Size)
            _MyOutSize = value
            Call NotifyPropertyChanged()
        End Set
    End Property
   '変形後の要素がピッタリ収まる四角枠
    Private Property _MyOutBounds As Rect
    Public Property MyOutBounds As Rect
        Get
            Return _MyOutBounds
        End Get
        Set(value As Rect)
            _MyOutBounds = value
            Call NotifyPropertyChanged()
        End Set
    End Property
   '変形前後の元左上座標の差分
    Private Property _MyDiffPointTopLeft As Point
    Public Property MyDiffPointTopLeft As Point
        Get
            Return _MyDiffPointTopLeft
        End Get
        Set(value As Point)
            _MyDiffPointTopLeft = value
        End Set
    End Property
   '変形後の元左上座標
    Private Property _MyTransformedTopLeft As Point
    Public Property MyTransformedTopLeft As Point
        Get
            Return _MyTransformedTopLeft
        End Get
        Set(value As Point)
            _MyTransformedTopLeft = value
            Call NotifyPropertyChanged()
        End Set
    End Property

#End Region

   'ControlTemplate作成、Canvasを一個入れるだけ
    Private Function CreateTemplate() As ControlTemplate
        Dim ct As New ControlTemplate(GetType(Thumb))
        Dim c As New FrameworkElementFactory With {.Name = "RootCanvas", .Type = GetType(Canvas)}
        ct.VisualTree = c
        Return ct
    End Function
   'コンストラクタ
   '渡された要素をTemplateの中のCanvasに追加する
    Public Sub New(elm As FrameworkElement)
        Template = CreateTemplate()
        ApplyTemplate() 'Templateを再構築、必要
       'TemplateのCanvasを取得して渡された要素を追加
        RootCanvas = Me.Template.FindName("RootCanvas", Me)
        With RootCanvas
            .Children.Add(elm) 'TemplateのCanvasに追加
            .Children.Add(New Label With {.Content = "左上"}) '目印用にLabelを追加
            .Height = elm.Height
            .Width = elm.Width
        End With
        testRootCanvas = RootCanvas 'test

       '各種TransformをGroupにしてTemplateのCanvasのRenderTransformに指定
        RootRotate = New RotateTransform
        Dim sc As New ScaleTransform
        Dim sk As New SkewTransform
        Dim tg As New TransformGroup
        With tg.Children
            .Add(sc) : .Add(sk) : .Add(RootRotate)
        End With
        With RootCanvas
            .RenderTransformOrigin = New Point(0.5, 0.5)
            .RenderTransform = tg
            .Background = Brushes.Transparent
        End With

       'ピッタリ枠とかを更新するため
        Call SetDiffPointAndOutSize()
    End Sub
End Class





'RectをRectangleGeometryに変換
Public Class MyConverterRect
    Implements IValueConverter
    Public Function Convert(value As Object, targetType As Type, parameter As Object, culture As CultureInfo) As Object Implements IValueConverter.Convert
       '   Throw New NotImplementedException()
        Dim r As Rect = value
        Dim rg As New RectangleGeometry(r)
        Return rg
    End Function
    Public Function ConvertBack(value As Object, targetType As Type, parameter As Object, culture As CultureInfo) As Object Implements IValueConverter.ConvertBack
        Throw New NotImplementedException()
    End Function
End Class
 
 
 
前回のものに書き加えたところ
マウスドラッグ移動の部分にグリッドスナップ移動
イメージ 5
ThumbコントロールにはDragDeltaって言う便利なイベントがあって
マウスの横移動距離がe.HorizontalChangeで取得できるので、これを
今の位置に足した値を指定するだけでマウスの移動距離分移動させることができる
Canvas要素に表示しているなら
横位置の取得はCanvas.GetLeft
横位置の指定はCanvas.SetLeft
グリッドスナップしないならこれでOK、前回の記事はこれだった
''通常移動
        'MyExThumb.MyLeft += e.HorizontalChange
        'MyExThumb.MyTop += e.VerticalChange
 
今回のグリッドスナップは左上にあるグリッドにスナップすることにしたので
グリッドサイズが10なら10で割って小数点以下を切り捨てた値にグリッドサイズをかけた値に移動
 
元の横位置が115でマウスが横に1(右に1)動いた場合は
115+1=116、これを10で割って
116/10=11.6、小数点以下を切り捨てた値は
11、これにグリッドサイズの10をかけた値は
110なので110へ移動させる
 
マウスが横に-18(左に18)動いた場合は
115+(-18)=97
97/10=9.7
9
9*10=90
90へ移動させる
 
うーん、115から右に1動かした結果、左に移動することになるのは不自然だから直したほうが良さそうね
 
VBだと「\」って言う演算子を使うと割り算後の小数点切り捨ての値が得られる
\は\(バックスラッシュ)なんだけどフォントによって表示が円マークになる
 

 
目印用のグリッド(罫線)の表示
イメージ 6
Path要素を使って表示している、グリッドサイズをスライダーで変更した時にこれを実行して表示を更新している
 

 
 
変形後の要素がピッタリ収まる枠(青枠)の表示
イメージ 7
これもPath要素で表示している、PathRectがそれ
これのDataPropertyにMyOutBoundsをバインディングしている
バインディングのソースをRect、バインディングのターゲットをPath要素のDataPropertyにしている
 
DataPropertyに指定できるのはGeometryだけどMyOutBoundsはRectなので
RectをGeometryに変換する必要があるのでMyConverterRectっていうConverterを作成して使っている
 
MyConverterRect
イメージ 8
いっぱい書いてあるけど実際に書くのは青色背景の5行だけで後は自動で記入されるし、3行のところもホントは1行で済む
Return New RectangleGeometry(value)
 
Public Function Convertがソースからの値をターゲットへ渡す流れ
Public Function ConvertBackがその逆の流れになる
今回はConvertの方だけ使用
 
引数のValueバインディングする値が入っている、ソースの値なのでMyOutBoundsのRectが入っているのでこれをRectangleGeometryに変換といっても
Rectを渡してRectangleGeometryを作成するだけ
これを返せば完了
 

 
 
 
 
 
 
 
前回のWPF記事
WPF、変形した要素を指定位置に移動、NotifyProperty ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
https://blogs.yahoo.co.jp/gogowaten/14998511.html
 
次の記事は今回の続きは6日後
WPF、変形後の要素の4辺をグリッドスナップしながらドラッグ移動 ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
https://blogs.yahoo.co.jp/gogowaten/15011638.html