ここから本文です
ベランダ菜園とWindows用アプリ作成とExcel用アプリ(アドイン)作成

書庫VB.NET

VisualBasic
VisualStudioExpress2010と2013でWindowsForm
2015年夏からはVisual Studio Community 2015でWPF
2017年春からはVisual Studio Community 2017
記事検索
検索

全20ページ

[1] [2] [3] [4] [5] [6] [7] [8] [9] [10] [11]

[ 次のページ ]

Windows FormアプリをVisual Basicで
イメージ 1
マウスドラッグでラベルコントロールの移動と直線の描画


2014/12/19は5年前
マウスドラッグでラベルコントロールの移動と直線の描画 ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
https://blogs.yahoo.co.jp/gogowaten/12509328.html
このときと同じなんだけど、書き直してみた



イメージ 3
直線はGraphicsクラスのDrawLinesを使って描画
DrawLinesはPointの配列を渡すと、各Point間を直線で描画してくれる

各Pointの■はLabelを使って表示、これをマウスドラッグで移動できるようにして、移動させたら直線も再描画

LabelとPointの関連付けは、LabelのTagプロパティに通し番号を入れて、Pointの配列のindexと合わせるようにしている

ここまでは5年前と同じ

書き直したところ
5年前はPictureBoxを継承したクラスを作成して、そこに各Pointの情報を記録していたけど、今回のは新しいクラスを作成しないで書いてみた



Form1.vb

'直線の描画
'頂点はLabelコントロールで表示して、マウスドラッグで移動できるように


Public Class Form1
Private beginPoint As Point 'マウスドラッグ開始点記録用
Private myPen As New Pen(Brushes.Magenta, 5) '直線用のPen
Private myPoints As New List(Of Point) '頂点座標群記録用

Private Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load
Call MyInitialize()
End Sub

'初期化
Private Sub MyInitialize()
'初期座標設定
myPoints = New List(Of Point)(New Point() {
  New Point(0, 0),
  New Point(150, 40),
  New Point(80, 100),
  New Point(100, 150)})
'頂点表示用のLabel作成
For i = 0 To myPoints.Count - 1
Call MakeLabel(myPoints(i), i)
Next

'直線を描画
Call MyDrawLines()

End Sub

'左クリック時の処理
Private Sub MyMouseDown(sender As Object, e As MouseEventArgs)
beginPoint = e.Location
End Sub

'マウスドラッグ中処理
Private Sub MyMouseMove(sender As Object, e As MouseEventArgs)
If e.Button = Windows.Forms.MouseButtons.Left Then
Dim myLabel = DirectCast(sender, Label)
Dim newLocate As Point
newLocate = New Point(e.X - beginPoint.X + myLabel.Location.X,
  e.Y - beginPoint.Y + myLabel.Location.Y)
myLabel.Location = newLocate
myPoints(myLabel.Tag) = newLocate
Call MyDrawLines()
End If
End Sub

'直線を描画
Private Sub MyDrawLines()
Dim canvas As New Bitmap(Me.PictureBox1.Width, Me.PictureBox1.Height)
Dim g As Graphics = Graphics.FromImage(canvas)
g.DrawLines(myPen, myPoints.ToArray)
g.Dispose()
Me.PictureBox1.Image = canvas

End Sub

''' <summary>
''' 頂点表示用のLabel作成
''' </summary>
''' <param name="locate">頂点座標</param>
''' <param name="number">通し番号(何番目の頂点なのか識別用)</param>
''' <returns></returns>
Private Function MakeLabel(locate As Point, number As Integer) As Point
Dim myLabel = New Label()
With myLabel
.Width = 10
.Height = 10
.BackColor = Color.Black
.Location = locate
.Tag = number 'Tagに通し番号を記録
End With
Me.PictureBox1.Controls.Add(myLabel)
'マウスイベント時の処理追加
AddHandler myLabel.MouseDown, AddressOf MyMouseDown
AddHandler myLabel.MouseMove, AddressOf MyMouseMove

End Function

End Class


デザイン画面
イメージ 2
PictureBox1を追加しただけ




ギットハブ




関連記事
マウスクリックでCanvasに直線を描画その2、Polyline、WPFとC# ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
https://blogs.yahoo.co.jp/gogowaten/15540488.html






ブログ
平均室温が32度を超えたあたりで睡眠不足で頭が休眠状態になるけど
今日は珍しく涼しい(今の室温30.9度)ので、なんとか動けて
配列の初期化の方法をググるところから開始
このまま涼しくなってくれるといいねえ







前回からの続きで、今回ので満足できるところまでできた

変形後の要素の4頂点をグリッド頂点にスナップ
イメージ 1
変形(20度回転)後の要素の四隅の頂点を順番にを100,100の位置にスナップ移動させている
できたなあ
一年前に失敗したのと同じ考え方なんだけど、書き方を変えてみたら期待どおりの動きにできた
今回の動画もマウスの調子が良くないから何回も撮り直した


一年前と同じ考え方
この左上頂点の場合はBが一番近い、これを左上頂点の目標グリッドとして
これを各4頂点調べるから
4*4=16通りの中で一番近いところへ移動させる




各4頂点の目標グリッドなどの情報を入れておくStructure(構造体)を



Public Structure MyTargetGridPointData
    Dim TargetGridPoint As Point '目標グリッド位置
    Dim Distance As Double '距離
    Dim IsValid As Boolean '
    Dim DiffPoint As Point '元の位置からの差分
End Structure



こんなふうに作っておいて
あとは



'指定位置から一番近いグリッド位置を返す
Private Function GetNearGridPointDistance(xy As Double, gridSize As Integer) As Double
Dim m As Double = xy Mod gridSize
If m > gridSize / 2 Then
Return xy + gridSize - m
Else
Return xy - m
End If
End Function

'指定座標から一番近いグリッド頂点の座標を返す
Private Function GetNearestGridPoint(dp As Point, gridSize As Integer) As Point
Dim x As Double = GetNearGridPointDistance(dp.X, gridSize) '最寄りのグリッドx座標
Dim y As Double = GetNearGridPointDistance(dp.Y, gridSize) '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

''' <summary>
''' 移動後の座標から一番近いグリッド頂点や距離、移動前からの距離などを返す
''' </summary>
''' <param name="gridSize">グリッドサイズ</param>
''' <param name="transformedPoint">移動前の座標</param>
''' <param name="mMove">マウスの移動座標</param>
''' <returns></returns>
Private Function GetPointData(gridSize As Integer, transformedPoint As Point, mMove As Point) As MyTargetGridPointData
Dim tPoint As New MyTargetGridPointData
With tPoint
'移動後地点の最寄りのグリッド頂点
.TargetGridPoint = GetNearestGridPoint(transformedPoint + mMove, gridSize)
'その距離
.Distance = GetDistance(transformedPoint + mMove, .TargetGridPoint)
'今回は未使用、値が有効かどうか
.IsValid = True
'移動前の地点から最寄りのグリッド頂点までの差分
.DiffPoint = transformedPoint - .TargetGridPoint

End With
Return tPoint
End Function

''' <summary>
''' 元の4頂点グリッドスナップ用、4頂点の最寄りのグリッド頂点を取得、一番近いグリッド頂点情報を返す
''' </summary>
''' <param name="gridSize">グリッドサイズ</param>
''' <param name="mMove">マウスの移動距離</param>
''' <param name="TopLeftXY">変形後の左上の位置</param>
''' <param name="TopRightXY">変形後の右上の位置</param>
''' <param name="BottomRightXY">変形後の右下の位置</param>
''' <param name="BottomLeftXY">変形後の左下の位置</param>
''' <returns></returns>
Private Function GetMyTargetGrid4Point2(gridSize As Integer, mMove As Point,
 TopLeftXY As Point, TopRightXY As Point, BottomRightXY As Point, BottomLeftXY As Point) As MyTargetGridPointData
'移動後の各4頂点の最寄りのグリッド頂点のData取得
Dim TLData As MyTargetGridPointData = GetPointData(gridSize, TopLeftXY, mMove)
Dim TRData As MyTargetGridPointData = GetPointData(gridSize, TopRightXY, mMove)
Dim BRData As MyTargetGridPointData = GetPointData(gridSize, BottomRightXY, mMove)
Dim BLData As MyTargetGridPointData = GetPointData(gridSize, BottomLeftXY, mMove)
'一番近いグリッド頂点を取得する
'4データを一旦リストに入れる
Dim dataList As New List(Of MyTargetGridPointData) From {TLData, TRData, BRData, BLData}

'SortedListに入れて並べ替える、距離をkeyにして昇順
Dim sl As New SortedList(Of Double, MyTargetGridPointData)
'同じ距離があった場合にリストに追加しようとするとエラーになるのでtryで無視して次のDataを入れていく
For i As Integer = 0 To 3
Try
sl.Add(dataList(i).Distance, dataList(i))
Catch ex As Exception

End Try
Next
'Dim rv As MyTargetGridPointData = sl.Values(0)
'一番近いDataを返す
Return sl.Values(0)

End Function



これをDragDeltaイベントのところで



Dim GridSize As Integer = sldGrid.Value'グリッドサイズ
Dim hChange As Double = e.HorizontalChange'マウス横移動距離
Dim vChange As Double = e.VerticalChange'マウス縦移動距離
'変形後の元の4頂点をグリッドの頂点にスナップ
'4頂点それぞれの最寄りのグリッド頂点の中から一番近いグリッド頂点やその距離の差分などを取得
Dim pData As MyTargetGridPointData = GetMyTargetGrid4Point2(GridSize, New Point(hChange, vChange), MyExThumb.MyTransformedTopLeft, MyExThumb.MyTransformedTopRight, MyExThumb.MyTransformedBottomRight, MyExThumb.MyTransformedBottomLeft)
'今と違う位置(距離の差分が0以外)ならその場所へ移動
If pData.IsValid Then
If pData.DiffPoint.X <> 0 Then MyExThumb.MyLeft -= pData.DiffPoint.X
If pData.DiffPoint.Y <> 0 Then MyExThumb.MyTop -= pData.DiffPoint.Y
End If


MyExThumbはThumbを継承して作ったクラスで
MyExThumb.MyLeftプロパティは値変更のところでCanvas.SetLeftを実行している


こんなふうに書いたらうまく行ったけど、なんかよくわかっていないんだよねえ、暑くて考えることができない

SortedListにデータ追加するところを書き換えた
一番近い距離のものを取得するのにSortedListクラスを使うのも一年前と同じなんだけど、少し書き直した
SortedListはkeyとValueを対でデータを追加していく、そうするとkeyの値の順番で自動で並び替えて登録される、なのでkeyに距離を指定すれば距離順に並ぶので簡単に一番近いものが取得できるけど、同じ値のkeyは登録しようとしてもできない(エラーになる)ので、もし別の場所で同じ距離の頂点データが出たときには、その頂点は無視して次のデータへ行くようにする処理にしたのが赤背景のところ


おまけで
変形後の要素の4辺or4頂点をグリッドスナップ
っていうのもできた

イメージ 2
変形後の要素がぴったり収まる枠(青枠)の上辺と左辺がグリッドスナップしている状態
ここから下に移動させると

イメージ 3
左下頂点がグリッド頂点にスナップ!
ここから下に移動させると

イメージ 4
右上頂点がグリッドラインにスナップ
次は

イメージ 5
青枠下辺がグリッドラインにスナップ
こんなふうに頂点や枠を近くのグリッドラインや頂点にスナップする
動きが細かすぎて使うかどうかはわからないけどこういうのもできた
この処理は前回の記事のコードの延長みたいなもので難しくないはずなんだけど今見たらよくわかんないや
暑いと頭動かない
只今(午後9時43分)の室温33.3、湿度54
でも昨日、一昨日に比べたら少しマシだなあ



今回のコード全部は
20170708_4頂点グリッドスナップ - Visual Studio Team Services
今回のでグリッドスナップの動きは全部できたかなあ、細かい不満はあるけど1年前と違って実用できる動きにできた





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



2016/05/14
一年前の記事、このときはいまいちな結果だった
WPFとVB.NET、回転したコントロールをマウスドラッグでグリッドスナップ、SortedListはスゴイヤツ ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
https://blogs.yahoo.co.jp/gogowaten/14136957.html




















前回からの続きで
今回の目的は
変形した要素がピッタリ収まる四角枠の4辺をグリッドスナップするマウスドラッグ移動


イメージ 1
青枠がぴったり枠で水色罫線がグリッド



どんな処理をすればいいのかエクセル方眼紙を使って考えてみた
エクセル方眼紙は便利なんだよなあ
イメージ 2


イメージ 3

イメージ 4

イメージ 5

イメージ 6
これで横の位置は決められる
上下移動で縦の位置も左右を上下に入れ替えれば同じようにできる




横移動の場合の目標グリッドの選択
両辺それぞれの左右にグリッドがあって、どちらのグリッドに合わせたらいいのかはマウスの移動方向で決める
マウスが右方向に移動していたら辺の左側を目標グリッドにする
これは、右側のグリッドはマウスの移動距離が足りなくてまだ到達していないグリッドなので目標にしても意味が無いから

目標グリッドの位置を求める
条件
左辺の初期位置が35.91、グリッドサイズが50、マウスの移動距離が50
イメージ 7
この時
初期位置+マウスの移動距離=今(移動後)の位置
35.91+50=85.91
これをグリッドサイズで割って
85.91/50=1.7182
マウスの移動距離がプラス値なら右移動、マイナス値なら左移動なので、移動距離50は右移動
右移動のときは左側を目標グリッドにする
今の位置1.7182ってことは1番目と2番めのグリッドの間にあるってことだから、左側のグリッドは1番目のグリッドってことになる
これは1.7182の小数点を切り捨てる処理をすればいい
グリッドサイズは50なので1*50=50
左辺の目標グリッド位置は50

右移動で移動後の位置がプラス値なら単純に小数点以下切り捨てればいいんだけど
マイナス値、例えば-1.5だと切り捨てると-1.0になってしまい、これだと右側になってしまう、なので別の丸め処理をする必要があって、その一覧
イメージ 8
ワークシート関数だとTRUNCとROUNDUPの2種類
VB.NETだとMath.FloorとMath.Ceilingの2種類
これで対応できた
.NETのほうにもMath.Truncateっていうのがあるんだけど
今回はFloorのほうが都合が良かった

これらは
小数点を切り捨て、切り上げ、四捨五入する: .NET Tips: C#, VB.NET
http://dobon.net/vb/dotnet/programing/round.html
こちらを参考にしました、ありがとうございます!


右辺の目標グリッドも同じように求めるので
164.09+50=214.09
214.09/50=4.2828
TRUNC(4.2828,0)=4
4*50=200
右辺の目標グリッド位置は200

それぞれの目標グリッドが得られたら、その方向と距離は有効なのかを判定
方向判定
左辺の目標グリッドは50で、左辺初期位置は35.91
初期位置から見て目標グリッドは右、マウスの移動も右なので方向は有効
右辺の目標グリッドは200で、右辺初期位置は164.09
初期位置から見て目標グリッドは右、マウスの移動も右なので方向は有効

距離判定
マウスの移動距離は50
左辺初期位置から左辺の目標グリッドまでの距離は
35.91-50=-14.09
距離は絶対値なので14.09
これよりマウスの移動距離が大きければいいので左辺移動距離は有効
右辺は
Math.Abs(164.09-200)=35.91
50>=35.91はTrueなので右辺移動距離も有効

有効判定
方向、距離のどちらも有効な場合だけその目標グリッドは有効になる
左辺、右辺の方向、距離ともに有効なので両辺ともに有効

両辺ともに有効なら近い方のグリッドを選ぶ
左辺の距離
左辺の目標グリッドー(左辺初期位置+マウスの移動距離)
=50-(35.91+50)=-35.91
=35.91
右辺の距離
=200-(164.09+50)=-14.09
=14.09
右辺のほうが近いので右辺を200の位置に移動



エクセルで確認してみる
イメージ 9

初期位置やマウスの移動距離を変更してみる
イメージ 10
エクセルは数値を変更すればすぐに確認できるから便利なんだよなあ
どんな処理や関数が必要なのかも目安が付けやすいし、処理の流れも確認しやすいと思った(小並感)

VBで書いたのがこれ、文字数節約のため画像
イメージ 11
これ(GetTargetSideLocate)をThumbのDragDeltaイベントのところから呼び出して使う

結果
イメージ 12
できた!期待どおりの動き!

これで変形後のぴったり枠の4辺のグリッドスナップはできたので
残るは去年挑戦したけどうまくできなかった変形後の4頂点のグリッドスナップ


限界突破
今回のコードは長すぎてヤフーブログの文字数上限を超えていたので
こっち
今月に入ってから暑くなって今年も限界が近づいてきたなあ
昼間に室温35度を超えるのは全く問題ないけど
深夜0時に室温33.9度は限界超えてるでしょ、暑くてうまく寝られないから睡眠不足が続いてだんだん頭が動かなくなる
平均室温33.375度はいろいろ限界だと思った



前回の記事
WPF、変形後の要素(Thumb)のグリッドスナップ移動 ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
https://blogs.yahoo.co.jp/gogowaten/15001512.html




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










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

グリッドスナップ移動
イメージ 2
橙色の四角要素をグリッド(水色罫線)に合わせて移動するとき
左上をグリッドに合わせて移動するようにしたい
要素を回転(変形)させるといろいろな左上ができる

回転後のいろいろな左上
イメージ 1
赤枠、青枠はただの目印
赤枠は回転前の位置とサイズ
青枠は回転後の要素がピッタリ収まる位置とサイズ
この2つの枠の左上が赤青矢印の先と
元の左上が回転で移動した橙色矢印の先
この3つを切り替えてスナップ移動

イメージ 3
できた!
見てて思ったのが赤枠基準はいらないかなあってのと
シングルクリックがダブルクリックになったり
マウスドッラグ中にクリックになったりしない、そんな
マウスがほしい



デザイン画面とXAML、XAMLを書くと投稿エラーになるから画像で表示するのです
イメージ 4



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


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







要素を指定した位置に移動させる
イメージ 1
 水色の四角枠は目印、サイズ100x100、x,y=100,100
赤の四角が目的の要素、サイズ100x100
移動ボタン1と2どちらも100,100へ移動させるボタンだけど基準が違う
基準A:ボタン1は見た目上の位置
基準B:ボタン2は内部的な位置

変形後も内部の位置やサイズは変化しないから見た目とズレるから、このズレを計算しての位置指定
変形後の要素を他の要素にピッタリ重ねたいとか、横にくっつけたいとかしたいので基準Aの方法が必要だった
x,y=100,100のとき20度回転させると
イメージ 2
x,y=85.9,85.9にズレる
これを100,100にするにはズレの分だけずらせばいい
ズレは-14.1なので
100+(-(-14.1))=114.1
イメージ 3
100,100ぴったりになった



要素の中心を軸に回転させるとピッタリ収まる四角枠は位置もサイズも変化する

今回の赤の四角はThumbなんだけど
Canvasを入れたControlTemplateを作ってそれをThumbのTemplateに指定して、そのCanvasに赤のBorderを入れている
Thumb.Template
┗Canvas
┗Border
変形させているのはTemplateのCanvas



用意したPriorityは全部NotifyPriority通知プロパティにした
MyLeft X座標、左位置
MyTop Y座標、上位置
MyAngle 回転角度
DiffPoint 見た目と中身の位置の差分
OutSize 見た目の大きさ、ぴったり枠のサイズ
MyOutBounds ぴったり枠の位置とサイズ



TransformToVisualとTransformBoundsを使うと要素の変形後のRect(サイズや位置)を取得することができる

Dim gt As GeneralTransform = 要素.TransformToVisual(今回はThumb)
Dim r As Rect = gt.TransformBounds(New Rect(New Size(要素.Width, 要素.Height)))
イメージ 4
この場合だと位置はズレの値(Thumbとの相対的な位置)になっている(-14.05…)
これをDiffPointに入れておいて
サイズ(128.17…)はOutSizeに入れておく



変形(回転)させたらぴったり枠も更新するので
MyAngleのSetのところでそれを実行する
イメージ 5
RootRotate.Angle=Valueが実際に回転指定しているところ


DiffPoint 見た目と中身の位置の差分
OutSize 見た目の大きさ、ぴったり枠のサイズ
を更新して
イメージ 6
MyOutBounds ぴったり枠の位置とサイズ
これも更新
イメージ 7



移動させたときは
MyOutBoundsの位置の更新だけなので
MyLeftとMyTopのSetのところで
イメージ 8
Canvas.SetLeft(Me, Value)が実際に位置指定しているところ
そのあとのCall SetOutBoundsで
イメージ 9
x,yだけ差分を足して、サイズはそのまま




ぴったり枠基準(基準A)で指定位置に移動
指定された値に差分を足した値を指定
なのでMainWindowからは単純に
MyExThumb.SetPoint2(100, 100)
だけで見た目上の100,100の位置に移動させることができる
イメージ 11




デザイン画面、XAMLを書くと投稿エラーになるから画像で
イメージ 10


VBコード
MainWindowとThumbを継承したExThumb


Imports System.ComponentModel
Imports System.Windows.Controls.Primitives


Class MainWindow

Private WithEvents MyExThumb As ExThumb

Private Sub MyCheck()
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 MyMove2()
MyExThumb.SetPoint2(0, 0)
End Sub
Private Sub MyMove3()
MyExThumb.MyLeft = 0
MyExThumb.MyTop = 0
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
AddHandler btnCheck.Click, AddressOf MyCheck
'AddHandler btn1.Click, AddressOf MyMove2
AddHandler btn2.Click, AddressOf MyCheck2
'AddHandler btn3.Click, AddressOf MyMove3
AddHandler btn4.Click, AddressOf MyMove

'ExThumbに100x100の赤Borderを追加してMyCanvasに表示
Dim ext As New ExThumb(New Border With {
  .Width = 100, .Height = 100, .Background = Brushes.Red, .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.DiffPoint), tbRect) '差分座標
Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyLeft), tbLeft) '実際のX座標
Call SetTextBlockBinding(MyExThumb, NameOf(ExThumb.MyOutBounds), tbBounds) '見た目のピッタリ枠

End Sub

Private Sub MyExThumb_DragDelta(sender As Object, e As DragDeltaEventArgs) Handles MyExThumb.DragDelta
MyExThumb.MyLeft += e.HorizontalChange
MyExThumb.MyTop += e.VerticalChange
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 + (-DiffPoint.X)
MyTop = y + (-DiffPoint.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)))
DiffPoint = r.Location
OutSize = r.Size
Call SetOutBounds()
End Sub

'OutBoundsの更新、移動時に実行する
Private Sub SetOutBounds()
Dim r As Rect = New Rect(New Point(DiffPoint.X + MyLeft, DiffPoint.Y + MyTop), OutSize)
MyOutBounds = r

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 _DiffPoint As Point
Public Property DiffPoint As Point
Get
Return _DiffPoint
End Get
Set(value As Point)
_DiffPoint = value
Call NotifyPropertyChanged()
End Set
End Property
'要素がピッタリ収まるサイズ
Private Property _OutSize As Size
Public Property OutSize As Size
Get
Return _OutSize
End Get
Set(value As Size)
_OutSize = value
Call NotifyPropertyChanged()
End Set
End Property
'回転角度
Private Property _MyAngle As Double
Public Property MyAngle As Double
Get
Return _MyAngle
End Get
Set(value As Double)
_MyAngle = value
RootRotate.Angle = value
Call NotifyPropertyChanged()
Call SetDiffPointAndOutSize()
End Set
End Property
'X座標
Private Property _MyLeft As Double
Public Property MyLeft As Double
Get
Return _MyLeft
End Get
Set(value As Double)
_MyLeft = value
Canvas.SetLeft(Me, value)
Call NotifyPropertyChanged()
Call SetOutBounds()
End Set
End Property
'Y座標
Private Property _MyTop As Double
Public Property MyTop As Double
Get
Return _MyTop
End Get
Set(value As Double)
_MyTop = value
Canvas.SetTop(Me, value)
Call NotifyPropertyChanged()
Call SetOutBounds()
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

#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)
.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

'ピッタリ枠とかを更新するために角度指定
MyAngle = 0.0

End Sub

End Class




前回までのDependencyPropertyを最初に使って試したけどうまく書けなくて
今回はNotifyPropertyっていう値が変更されたら通知を出せるプロパティを使った
うまくできなかったのは変形(Angleを変更)したときにTransformToVisualを使って変形後のRectを求めるところ、こんなふうに書いてみたけど
イメージ 12

イメージ 13

DependencyPropertyのPropertyMetadataのPropertyChangedCallbackのところでTransformToVisualを使ってみたんだけどこのタイミングだと変形する直前みたいで変形前のRectしか取得できなかった

なので今回のようにNotifyPropertyって言う値の変更時に通知を出せる通知プロパティを使った、これは一年前の方法とほとんど変わらないけど少しうまく書けた気がする


参照したところ
INotifyPropertyChanged インターフェイス (System.ComponentModel)
https://msdn.microsoft.com/ja-jp/library/system.componentmodel.inotifypropertychanged(v=vs.110).aspx?cs-save-lang=1&cs-lang=vb#code-snippet-1

特に紫の文字のコトロがすごい便利だった

Private Sub NotifyPropertyChanged(<System.Runtime.CompilerServices.CallerMemberName> Optional propertyName As String = Nothing)
RaiseEvent PropertyChanged(Me, New PropertyChangedEventArgs(propertyName))
End Sub

これがないと例えば

'変形前後の左上座標の差分
Private Property _DiffPoint As Point
Public Property DiffPoint As Point
Get
Return _DiffPoint
End Get
Set(value As Point)
_DiffPoint = value
Call NotifyPropertyChanged()
End Set
End Property


赤文字のところを
Call NotifyPropertyChanged("DiffPoint")
って書くか
Call NotifyPropertyChanged(NameOf(DiffPoint))
って書くことになる
これがなんにも書かなくても良くなるから打ち間違えることもないしラク






関連記事

前回の記事 2017/6/24
WPF、CanvasLeftTopとSliderValueをBinding ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
https://blogs.yahoo.co.jp/gogowaten/14988621.html


次の記事 2017/07/01
WPF、変形後の要素(Thumb)のグリッドスナップ移動 ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
https://blogs.yahoo.co.jp/gogowaten/15001512.html




昔の関連記事
2016/3/1
WPFとVB.NET、Canvasの中に回転表示したコントロールのドラッグ移動で気づいたこと ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
https://blogs.yahoo.co.jp/gogowaten/13947862.html
こんなふうに回転させるとその上で動くマウスの位置情報も回転されてめんどくさいので
ThumbのTemplateの中に入れたCanvasを回転させているのが今回の記事




全20ページ

[1] [2] [3] [4] [5] [6] [7] [8] [9] [10] [11]

[ 次のページ ]

本文はここまでですこのページの先頭へ
みんなの更新記事