WPFとVB.NET、回転したコントロールをマウスドラッグでグリッドスナップ、SortedListはスゴイヤツ

回転後のコントロールをマウスドラッグ移動するときに

グリッド移動(グリッドスナップ)

グリッドスナップする頂点は四角形の各4頂点すべての中で一番グリッドに近いもの

この条件での処理がなんとかできた感じ

wpf_37.gif

回転していない四角形の移動は今のPixtack紫陽花2ndや無印とほぼ同じ

今回作ったのは回転させて斜めになっている四角形の動き

少し怪しいｗけどだいたい期待通り

 

WPFではコントロールを回転させても内部的には回転していなくて

見た目だけが変化するので内部と見た目で差(ズレ)ができる

実際に座標を指定するときには内部のものを使うので

見た目と合わせるにはその差を取得する必要がある

 

最寄りのグリッド座標を取得する

左上に注目した場合に一番近いのはBなので

 

ここに移動させることができればいい

実際には左上、左下、右上、右下の4頂点の中から探すから

16通りの中で一番近いところになる

 

 

デザイン画面とXAML

VBコード

関係あるのは赤色のとろこだけ

Imports System.Windows.Controls.Primitives

Class MainWindow
    Private Const grid As Integer = 70 'グリッドの大きさ

    'グリッドをPathで描画
    Private Sub DrawGridLine()
        Dim pFigure As PathFigure
        Dim pGeometry As New PathGeometry
        '横線
        For i As Integer = 0 To 50
            pFigure = New PathFigure
            pFigure.StartPoint = New Point(i * grid, 0)
            pFigure.Segments.Add(New LineSegment(New Point(i * grid, 350), True))
            pGeometry.Figures.Add(pFigure)
        Next
        '縦線
        For i As Integer = 0 To 35
            pFigure = New PathFigure
            pFigure.StartPoint = New Point(0, i * grid)
            pFigure.Segments.Add(New LineSegment(New Point(500, i * grid), True))
            pGeometry.Figures.Add(pFigure)
        Next

        '描画
        Dim mPath As New Path With {.Stroke = Brushes.Blue, .StrokeThickness = 1, .Data = pGeometry}
        canvas1.Children.Add(mPath)
        Panel.SetZIndex(mPath, -1) '背面に移動

    End Sub

    'ドラッグ移動
    Private Sub thumb1_DragDelta(sender As Object, e As DragDeltaEventArgs) Handles thumb1.DragDelta
        Dim p As Point = GetOnCanvas(sender)
        Dim x As Double = p.X + e.HorizontalChange
        Dim y As Double = p.Y + e.VerticalChange

        x = x - (x Mod grid)
        y = y - (y Mod grid)
        Dim t As ExThumb = DirectCast(sender, ExThumb)
        SetOnCanvas(t, x, y)

    End Sub

    '対象を指定座標にセット
    Private Overloads Sub SetOnCanvas(t As ExThumb, x As Double, y As Double)
        Canvas.SetLeft(t, x)
        Canvas.SetTop(t, y)
        t.Locate = New Point(x, y)
    End Sub
    Private Overloads Sub SetOnCanvas(t As ExThumb, p As Point)
        Call SetOnCanvas(t, p.X, p.Y)
    End Sub

    '対象の座標を取得
    Private Function GetOnCanvas(obj As Object) As Point
        Return New Point(Canvas.GetLeft(obj), Canvas.GetTop(obj))
    End Function


    '基本座標と4頂点の差を記録
    Private Sub SetDiffPoint(t As ExThumb)
        Dim gt As GeneralTransform = t.TransformToVisual(canvas1)
        Dim BaseP As Point = New Point(Canvas.GetLeft(t), Canvas.GetTop(t))

        With t
            .Locate = BaseP '基本座標
            .DiffLTop = gt.Transform(New Point(0, 0)) - BaseP '左上頂点座標 - 基本座標
            .DiffRTop = gt.Transform(New Point(t.Width, 0)) - BaseP
            .DiffRDown = gt.Transform(New Point(t.Width, t.Height)) - BaseP
            .DiffLDown = gt.Transform(New Point(0, t.Height)) - BaseP
        End With
    End Sub




    '起動中
    Private Sub MainWindow_Initialized(sender As Object, e As EventArgs) Handles Me.Initialized
        Call DrawGridLine()
    End Sub

    '起動直後
    Private Sub MainWindow_Loaded(sender As Object, e As RoutedEventArgs) Handles Me.Loaded
        Call SetDiffPoint(thumb2) '起動中ではExThumbが表示されていないので起動直後
    End Sub



    '左上を最寄りのグリッドに合わせる
    Private Sub btLTop_Click(sender As Object, e As RoutedEventArgs) Handles btLTop.Click
        Call SetFitPoint(thumb2, thumb2.DiffLTop)
    End Sub
    '右上を最寄りのグリッドに合わせる
    Private Sub btRTop_Click(sender As Object, e As RoutedEventArgs) Handles btRTop.Click
        Call SetFitPoint(thumb2, thumb2.DiffRTop)
    End Sub

    '指定した頂点をグリッドに合わせる
    Private Sub SetFitPoint(t As ExThumb, fit As Point)
        '左上の座標が最寄りのグリッドからどれだけ離れているか距離を取得
        '離れているぶんを移動
        Dim fp As Point = t.Locate + fit 'グリッドに合わせたい頂点座標
        Dim x As Double = GetNearGridPoint(fp.X) '最寄りのグリッドx座標
        Dim y As Double = GetNearGridPoint(fp.Y) 'y座標

        Dim nx As Double = x - fp.X '最寄りのグリッド座標 - 今の座標 = 距離
        nx = t.Locate.X + nx '今の座標 + 距離 = グリッドにぴったりになる座標
        Dim ny As Double = y - fp.Y
        ny = t.Locate.Y + ny

        Call SetOnCanvas(t, nx, ny) '座標をセット
        't.Locate = New Point(nx, ny)
    End Sub

    '距離取得
    Private Function GetNearGridPoint(xy As Double) As Double
        Dim m As Double = xy Mod grid
        If m > grid / 2 Then
            Return xy + grid - m
        Else
            Return xy - m
        End If
    End Function

    'ドラッグ移動
    Private Sub thumb2_DragDelta(sender As Object, e As DragDeltaEventArgs) Handles thumb2.DragDelta
        Dim t As ExThumb = DirectCast(sender, ExThumb)
        Dim mp As New Point(e.HorizontalChange, e.VerticalChange) '移動距離
        Dim np As Point = GetNearPoint(t, mp) '最寄りのグリッドまでの距離取得
        np = np + t.Locate + mp '最寄りのグリッド ＋ 今の座標 ＋ 移動距離 ＝ ピッタリの座標
        Call SetOnCanvas(t, np) '座標指定
    End Sub


    '最寄りのグリッドにピッタリの座標になるために移動する分の座標を返す
    Private Function GetNearPoint(t As ExThumb, addPoint As Point) As Point
        '四角形(ExThumb)の座標
        Dim bp As Point = t.Locate + addPoint
        '4頂点の現在の座標
        Dim LT As Point = t.DiffLTop + bp '左上の頂点座標
        Dim RT As Point = t.DiffRTop + bp
        Dim RD As Point = t.DiffRDown + bp
        Dim LD As Point = t.DiffLDown + bp
        '4頂点それぞれの最寄りのグリッド座標
        Dim ltg As Point = GetXYDistance(LT) '左上の頂点に一番近いグリッド座標
        Dim rtg As Point = GetXYDistance(RT)
        Dim rdg As Point = GetXYDistance(RD)
        Dim ldg As Point = GetXYDistance(LD)
        'それぞれのグリッドまでの距離
        Dim ltd As Double = GetDistance(LT, ltg) '左上の頂点からグリッド座標までの距離
        Dim rtd As Double = GetDistance(RT, rtg)
        Dim rdd As Double = GetDistance(RD, rdg)
        Dim ldd As Double = GetDistance(LD, ldg)
        '現在の座標と最寄りのグリッド座標の差
        LT = ltg - LT '左上頂点の最寄りのグリッド - 現在の左上
        RT = rtg - RT
        RD = rdg - RD
        LD = ldg - LD

        '4頂点の中から一番近い
        '一番近い座標を得るためにSortedListに座標の差を入れる
        'SortedListはKeyの順番で自動でソートしてくれる
        '        ジェネリックコレクション その3 SortedListとSortedDictionary (System.Collections.Generic) - Programming/.NET Framework/コレクション - 総武ソフトウェア推進所
        'http://smdn.jp/programming/netfx/collections/2_generic_3_sortedlist_sorteddictionary/#indexed_access

        Dim sl As New SortedList(Of Double, Point)
        sl.Add(ltd, LT)
        sl.Add(rtd, RT)
        sl.Add(rdd, RD)
        sl.Add(ldd, LD)
        Dim neko As Point = sl.Values(0)
        '座標の修正値を返す、
        'この座標と現在の座標を足したものが最寄りのグリッドにピッタリの座標になる
        Return sl.Values(0)
    End Function

    '指定座標から一番近いグリッドの座標を返す
    Private Function GetXYDistance(dp As Point) As Point
        Dim x As Double = GetNearGridPoint(dp.X) '最寄りのグリッドx座標
        Dim y As Double = GetNearGridPoint(dp.Y) 'y座標
        Return New Point(x, y)
    End Function

    '2点間の距離を返す
    Private Function GetDistance(p1 As Point, p2 As Point) As Double
        Dim x As Double = p1.X - p2.X
        Dim y As Double = p1.Y - p2.Y
        Dim rd As Double = Math.Sqrt(x ^ 2 + y ^ 2)
        Return rd
    End Function


    Private Sub bt2_Click(sender As Object, e As RoutedEventArgs) Handles bt2.Click
        Dim neko As ExThumb = thumb2
        Dim p As Point = GetNearPoint(thumb2, New Point(0, 0))
    End Sub


    Private Sub btAutoFit_Click(sender As Object, e As RoutedEventArgs) Handles btAutoFit.Click
        Dim p As Point = GetNearPoint(thumb2, New Point(0, 0))
        Dim np As Point = p + thumb2.Locate
        Call SetOnCanvas(thumb2, np)
        thumb2.Locate = np

    End Sub
End Class


Public Class ExThumb
    Inherits Thumb
    Public Property Locate As Point 'ExThumb自身の座標、基本になる座標
    Public Property DiffLTop As Point 'Locateから左上頂点座標までの差
    Public Property DiffRTop As Point '右上
    Public Property DiffRDown As Point '右下
    Public Property DiffLDown As Point '左下

End Class

'毎回計算するのはめんどいからExThumbに4頂点の座標のプロパティをもたせたほうが良さそう
'4頂点の座標は元の座標からの差を記録したほうが良さそう
'そうすれば4頂点の変更はExThumbの変形時だけに留められる

 

 

グリッドの大きさ指定

 

ExThumbクラス

マウスドラッグ移動に適したコントロールのThumbを継承したクラスを作成

名前はExThumbにした

このクラスには値をもたせているだけ

自身の座標のほかは四隅の座標までとの差

例えば自身の座標が(1, 2)の時に左上が(10, 20)だったら

DiffLTopは(10 - 1, 20 - 2) なので (9, 18)を入れておくことになる

この差が変化するのは回転させた時だけで、今回は回転角度は固定なので

アプリの起動直後に値を入れるだけになる

Locateだけは移動した時に書き換える

 

さっきのプロパティに値を入れる

SetDiffPoint

TransformToVisualで得られるGeneralTransformのTransformメソッドで元の位置から回転後の座標を取得できる

これをアプリの起動直後に実行するので

 

Loadedイベントで

 

2点間の距離を返す

GetDistance

中学校で習ったらしいけど全く憶えていなかったのでググってそのまま

 

指定した位置から一番近いグリッドの位置を返す

GetNearGridPoint

 

指定した座標から一番近いグリッドの座標を返す

GetXYDistance

さっきのGetNearGridPointを使っているけど

ひとつにまとめたほうが良かったかも、よくわからん

 

 

↑の3つのGet～を使って

どれくらい移動させればぴったりになるかを返す

GetNearPoint

引数は移動させるExThumbとマウスで移動した分の距離のPoint

16通りの中から一番近いところと場所を探す

四隅の頂点それぞれの一番近いグリッドとの距離を取得し終わっているのが

148行目

そこからその4つの中でさらに一番近いものとその場所を取得するために

SortedListっていうジェネリックコレクションってのを初めて使ってみた

他のコレクションと同じように値(Value)を入れるんだけど、値と一緒にペアとなる

Keyも入れられてさらにKey順に自動で並べ替えてくれるスゴイヤツ

 

SortedListにKeyとValueを入れたところ

23，25，34，36とKeyの順番で並んでいる

 

この自動並べ替え機能を利用して最小値となる座標を取得している

Keyに距離を入れて、Valueに座標を入れていけばKey順に並べてくれるので

先頭のValueを取り出せば、それが最短距離の座標になる

これが164行目

この最短距離の座標はグリッドまでの差なので、今の座標に足せばピッタリになる

あとはThumbのDragDeltaのイベントの時に呼び出すだけ

 

2017/07/10追記ここから

SortedListへの追加方法を↓のように修正

 

SortedListのkeyは同じ値を指定できないけど今回は

距離をkeyしているからもし同じ距離があった場合にエラーになってしまう

同じ距離のものはリストに追加しないで次の値を入れていきたいので

Try構文を使うようにした

今回のケースでは同じ距離になることはないみたいで一回もエラーにならなかったけどグリッドサイズや要素のサイズを変えた場合は同じ距離になることがあるので修正した

'keyに距離、Valueに座標のSortedListを作成
'異なる座標で距離が同じものがあった場合SortedListに追加しようとするとエラーになるので
'同じ距離だったものは無視して次の値を入れたいのでtryを使った
Dim dList As New List(Of Double) From {ltd, rtd, rdd, ldd}
Dim pList As New List(Of Point) From {LT, RT, RD, LD}
Dim sl As New SortedList(Of Double, Point)
For i As Integer = 0 To 3
    Try
        sl.Add(dList(i), pList(i)) 'リストに追加
    Catch ex As Exception

    End Try
Next
'座標の修正値を返す、
'リストは昇順に並び替えられているので0番目を返す
'この座標と現在の座標を足したものが最寄りのグリッドにピッタリの座標になる
Return sl.Values(0)

2017/07/10追記ここまで

 

ThumbのDragDeltaイベント

120行目でさっきのGetNearPointで差を取得

それに今の座標とマウスの移動分を足してピッタリの座標が121行目

122行目でCanvasに配置するSetOnCanvasで移動完了

 

SetOnCanvas

Canvas.SetLeftとCanvas.SetTopで配置しているだけ

 

 

ここまで作ったけどPixtack紫陽花2ndに使うかどうかまだわからない

今はグループ化に挑戦しているけどかなり難しくてもう10日くらい経ったのかな

いろいろ試しているうちにできあがったのが今回のもの

グループ化はできたとしても基礎からの大幅書き直しになるからすんごい時間かかりそう

無印の時と違ってテストを重ねて慎重になっていたはずなんだけど

やっぱりこうなったかあって感じ

 

グループ化もグリッド移動もエクセルのものを目指して作っているんだけど

今回改めてエクセルのグリッド移動の動きを見ていたら思っていたのとは違って

思っていたのは今回作った動きなんだけど、エクセルの方は回転後の図形を

グリッド移動(Altキー押しながらの移動)しても四隅の頂点とセルのグリッドには合わせて移動していない

 

エクセルで

回転した四角形を横方向にグリッド移動(Altキー押しながらの移動)した時

実際の動きは四隅の頂点とグリッドの頂点は合わないみたいで

4辺のどれかに合わせる感じなんだねえ

この動きもいつか作ってみたい

↓

2017/07/07は2ヶ月後、できた！

gogowaten.hatenablog.com

2017/07/07
WPF、変形後の要素の4辺をグリッドスナップしながらドラッグ移動 ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
https://blogs.yahoo.co.jp/gogowaten/15011638.html

 

 

頂点同士のスナップもできた、これも2ヶ月後

gogowaten.hatenablog.com

2017/07/13
WPF、変形後の要素(Thumb)の頂点をマウスドラッグで最寄りのグリッド頂点にスナップ ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
https://blogs.yahoo.co.jp/gogowaten/15022173.html

 

参照したところ

smdn.jp

ありがとうございます

 

 

5年後 

gogowaten.hatenablog.com

 

コード全部

Wpf_test115_グリッド移動2 - Visual Studio Team Services
https://gogowaten.visualstudio.com/WPF/_git/WPF_test7?path=%2FWpf_test115_%E3%82%B0%E3%83%AA%E3%83%83%E3%83%89%E7%A7%BB%E5%8B%952&version=GBmaster&_a=contents