今回のアプリのダウンロード先
グリッドスナップ移動
橙色の四角要素をグリッド(水色罫線)に合わせて移動するとき
左上をグリッドに合わせて移動するようにしたい
要素を回転(変形)させるといろいろな左上ができる
回転後のいろいろな左上
赤枠、青枠はただの目印
赤枠は回転前の位置とサイズ
青枠は回転後の要素がピッタリ収まる位置とサイズ
この2つの枠の左上が赤青矢印の先と
元の左上が回転で移動した橙色矢印の先
この3つを切り替えてスナップ移動
できた!
見てて思ったのが赤枠基準はいらないかなあってのと
シングルクリックがダブルクリックになったり
マウスドッラグ中にクリックになったりしない、そんな
マウスがほしい
デザイン画面と
XAML、
XAMLを書くと投稿エラーになるから画像で表示するのです
Imports System.ComponentModel
Imports System.Globalization
Imports System.Windows.Controls.Primitives
Class MainWindow
Private WithEvents MyExThumb As ExThumb
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
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
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
Dim b As Binding
b = New Binding(NameOf(ExThumb.MyAngle)) With {.Source = MyExThumb, .Mode = BindingMode.TwoWay}
sldAngle.SetBinding(Slider.ValueProperty, b)
Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyAngle), tbAngle)
Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyDiffPoint), tbRect)
Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyLeft), tbLeft)
Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyOutBounds), tbBounds)
Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyTop), tbTop)
Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyTransformedTopLeft), tbTTopLeft)
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
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
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
Implements ComponentModel.INotifyPropertyChanged
Private RootCanvas As Canvas
Private RootRotate As RotateTransform
Public testRootCanvas As Canvas
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
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
Private Sub SetOutBounds()
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
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
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
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
Public Sub New(elm As FrameworkElement)
Template = CreateTemplate()
ApplyTemplate()
RootCanvas = Me.Template.FindName("RootCanvas", Me)
With RootCanvas
.Children.Add(elm)
.Children.Add(New Label With {.Content = "左上"})
.Height = elm.Height
.Width = elm.Width
End With
testRootCanvas = RootCanvas
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
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
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
前回のものに書き加えたところ
マウスドラッグ移動の部分にグリッドスナップ移動
Thumbコン
トロールにはDragDeltaって言う便利なイベントがあって
マウスの横移動距離がe.HorizontalChangeで取得できるので、これを
今の位置に足した値を指定するだけでマウスの移動距離分移動させることができる
グリッドスナップしないならこれで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だと「\」って言う
演算子を使うと割り算後の小数点切り捨ての値が得られる
\は\(バックスラッシュ)なんだけどフォントによって表示が円マークになる
目印用のグリッド(罫線)の表示
Path要素を使って表示している、グリッドサイズをスライダーで変更した時にこれを実行して表示を更新している
変形後の要素がピッタリ収まる枠(青枠)の表示
これもPath要素で表示している、PathRectがそれ
これのDataPropertyにMyOutBoundsを
バインディングしている
DataPropertyに指定できるのはGeometryだけどMyOutBoundsはRectなので
RectをGeometryに変換する必要があるのでMyConverterRectっていうConverterを作成して使っている
MyConverterRect
いっぱい書いてあるけど実際に書くのは青色背景の5行だけで後は自動で記入されるし、3行のところもホントは1行で済む
Return New RectangleGeometry(
value)
Public Function Convertがソースからの値をターゲットへ渡す流れ
Public Function ConvertBackがその逆の流れになる
今回はConvertの方だけ使用
引数のValueにバインディングする値が入っている、ソースの値なのでMyOutBoundsのRectが入っているのでこれをRectangleGeometryに変換といっても
Rectを渡してRectangleGeometryを作成するだけ
これを返せば完了
次の記事は今回の続きは6日後