Visual Basic サンプル集 |
![]() ![]() ![]() ![]() ![]() ![]() ![]() ![]() |
Visual Basic 中学校 > Visual Basic サンプル集 > Visual Basic サンプル集目次 > Windows フォーム >
マウス操作で図形を描画する
2020/12/20
目次
このページで紹介するサンプルは Windowsフォームアプリケーションを前提にしています。
マウスをクリックした位置に次々と赤い線を描画する
この例はマウスでPictureBoxをクリックするたびに、その場所から、PiuctureBoxの左上に向けて線を次々と追加します。
Public Class
Form1 Dim paths As New List(Of Drawing2D.GraphicsPath) Private Sub PictureBox1_MouseClick(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseClick Dim point1 As Point = e.Location Dim point2 As New Point(0, 0) Dim path As New Drawing2D.GraphicsPath path.AddLine(point1, point2) paths.Add(path) PictureBox1.Invalidate() End Sub Private Sub PictureBox1_Paint(sender As Object, e As PaintEventArgs) Handles PictureBox1.Paint For Each path As Drawing2D.GraphicsPath In paths e.Graphics.DrawPath(Pens.Red, path) Next End Sub End Class |
マウスをなぞった軌跡を描画する
この例はマウスでなぞった位置に四角形を描画します。
フォームにPictureBox(PictureBox1)が1つ配置されていることが前提です。
Public Class Form1 Dim Strokes As New Stack(Of List(Of Point)) Private Sub PictureBox1_MouseDown(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseDown Strokes.Push(New List(Of Point)) End Sub Private Sub PictureBox1_MouseMove(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseMove '何かしらマウスのボタンが押されている場合 If Control.MouseButtons <> MouseButtons.None Then Strokes.Peek.Add(e.Location) 'マウスの位置を最新のストロークに追加 PictureBox1.Invalidate() 'PictureBox1の再描画を促す End If End Sub Dim drawPen As New Pen(Color.FromArgb(140, Color.Red), 12) Private Sub PictureBox1_Paint(sender As Object, e As PaintEventArgs) Handles PictureBox1.Paint For Each stroke As List(Of Point) In Strokes 'ストロークに含まれるすべてのPointを線で結んだ図形を生成 Dim path As New Drawing2D.GraphicsPath(stroke.ToArray, Enumerable.Repeat(Of Byte)(1, stroke.Count).ToArray) e.Graphics.DrawPath(drawPen, path) '生成した図形を描画 Next End Sub End Class |
メモ:初級講座(改訂版) 第17回でこのプログラムが登場します。
マウスをなぞった位置にリアルタイムに四角形を描画する
この例はマウスでなぞった位置に四角形を描画します。
フォームにPictureBox(PictureBox1)が1つ配置されていることが前提です。
Public Class
Form1 Private mouseDownPosition As Point 'ドラッグを開始したマウスの位置 Private mouseDragPosition As Point '現在ドラッグ中のマウスの位置 Private isMouseDown As Boolean 'マウスのボタンが押されているか Private selectPen As Pen 'ドラッグ中の四角形の描画に使用するペン Private Sub Form1_Shown(sender As Object, e As EventArgs) Handles MyBase.Shown 'ドラッグ中の四角形の描画に使用するペンを作成。青い点線のペンにする。 selectPen = New Pen(Color.Blue, 1) selectPen.DashStyle = Drawing2D.DashStyle.Dot End Sub Private Sub PictureBox1_Paint(sender As Object, e As PaintEventArgs) Handles PictureBox1.Paint e.Graphics.Clear(Color.White) '背景を白にする If Control.MouseButtons <> MouseButtons.Left Then 'マウスの左ボタンが押されていない場合何もしない Return End If 'ドラッグを開始したマウスの位置(mouseDownPosition)と現在ドラッグ中のマウスの位置(mouseDragPosition) 'から、描画すべき四角形の座標を計算する。 Dim activeRect As New Rectangle activeRect.X = Math.Min(mouseDownPosition.X, mouseDragPosition.X) activeRect.Y = Math.Min(mouseDownPosition.Y, mouseDragPosition.Y) activeRect.Width = Math.Abs(mouseDragPosition.X - mouseDownPosition.X) activeRect.Height = Math.Abs(mouseDragPosition.Y - mouseDownPosition.Y) 'ドラッグ中の四角形を描画 e.Graphics.DrawRectangle(selectPen, activeRect) End Sub Private Sub PictureBox1_MouseDown(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseDown 'マウスのボタンが押された場合、 mouseDownPosition = e.Location isMouseDown = True End Sub Private Sub PictureBox1_MouseMove(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseMove 'マウスを移動した場合 mouseDragPosition = e.Location PictureBox1.Invalidate() 'PictureBoxを強制的に再描画する End Sub Private Sub PictureBox1_MouseUp(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseUp 'マウスを離した場合 isMouseDown = False PictureBox1.Invalidate() 'PictureBoxを強制的に再描画する End Sub End Class |
マウスをなぞった位置にリアルタイムに四角形を描画し、マウスを離すとその位置に四角形を追加する
この例は上記の例に加えて、マウスを離すとその位置に四角形が追加します。
フォームにPictureBox(PictureBox1)が1つ配置されていることが前提です。
Public Class
Form1 Private paths As New List(Of Drawing2D.GraphicsPath) Private mouseDownPosition As Point 'ドラッグを開始したマウスの位置 Private mouseDragPosition As Point '現在ドラッグ中のマウスの位置 Private isMouseDown As Boolean 'マウスのボタンが押されているか Private selectPen As Pen 'ドラッグ中の四角形の描画に使用するペン Private Sub Form1_Shown(sender As Object, e As EventArgs) Handles MyBase.Shown 'ドラッグ中の四角形の描画に使用するペンを作成。青い点線のペンにする。 selectPen = New Pen(Color.Blue, 1) selectPen.DashStyle = Drawing2D.DashStyle.Dot End Sub Private Sub PictureBox1_Paint(sender As Object, e As PaintEventArgs) Handles PictureBox1.Paint e.Graphics.Clear(Color.White) '背景を白にする '追加されている図形を描画する。 For Each path In paths e.Graphics.FillPath(Brushes.Cyan, path) '水色で塗りつぶし e.Graphics.DrawPath(Pens.Blue, path) '青い枠線 Next If Control.MouseButtons <> MouseButtons.Left Then 'マウスの左ボタンが押されていない場合何もしない Return End If 'ドラッグを開始したマウスの位置(mouseDownPosition)と現在ドラッグ中のマウスの位置(mouseDragPosition) 'から、描画すべき四角形の座標を計算する。 Dim activeRect As Rectangle = CalcActiveRect(mouseDownPosition, mouseDragPosition) 'ドラッグ中の四角形を描画 e.Graphics.DrawRectangle(selectPen, activeRect) End Sub Private Function CalcActiveRect(startPosition As Point, endPosition As Point) As Rectangle Dim activeRect As New Rectangle activeRect.X = Math.Min(mouseDownPosition.X, mouseDragPosition.X) activeRect.Y = Math.Min(mouseDownPosition.Y, mouseDragPosition.Y) activeRect.Width = Math.Abs(mouseDragPosition.X - mouseDownPosition.X) activeRect.Height = Math.Abs(mouseDragPosition.Y - mouseDownPosition.Y) Return activeRect End Function Private Sub PictureBox1_MouseDown(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseDown 'マウスのボタンが押された場合、 mouseDownPosition = e.Location isMouseDown = True End Sub Private Sub PictureBox1_MouseMove(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseMove 'マウスを移動した場合 mouseDragPosition = e.Location PictureBox1.Invalidate() 'PictureBoxを強制的に再描画する End Sub Private Sub PictureBox1_MouseUp(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseUp 'マウスを離した場合 If isMouseDown = True Then Dim activeRect As Rectangle = Me.CalcActiveRect(mouseDownPosition, mouseDragPosition) If activeRect.Width * activeRect.Height > 0 Then '面積がある場合、この四角形を描画対象に追加する。 Dim path As New Drawing2D.GraphicsPath() path.AddRectangle(activeRect) paths.Add(path) End If isMouseDown = False End If PictureBox1.Invalidate() 'PictureBoxを強制的に再描画する End Sub End Class |
マウスをなぞった位置にリアルタイムに四角形を描画し、マウスを離すとその位置に四角形を追加し、後で追加された四角形をクリックすると色が変わる
この例は上記の例に加えて、マウスを離すとその位置に四角形が追加します。
フォームにPictureBox(PictureBox1)が1つ配置されていることが前提です。
Public Class
Form1 Private polygons As New List(Of Polygon) Private mouseDownPosition As Point 'ドラッグを開始したマウスの位置 Private mouseDragPosition As Point '現在ドラッグ中のマウスの位置 Private isMouseDown As Boolean 'マウスのボタンが押されているか Private selectPen As Pen 'ドラッグ中の四角形の描画に使用するペン Private Sub Form1_Shown(sender As Object, e As EventArgs) Handles MyBase.Shown 'ドラッグ中の四角形の描画に使用するペンを作成。青い点線のペンにする。 selectPen = New Pen(Color.Blue, 1) selectPen.DashStyle = Drawing2D.DashStyle.Dot End Sub Private Sub PictureBox1_Paint(sender As Object, e As PaintEventArgs) Handles PictureBox1.Paint e.Graphics.Clear(Color.White) '背景を白にする '追加されている図形を描画する。 For Each polygon In polygons If polygon.IsSelected Then e.Graphics.FillRectangle(Brushes.Yellow, polygon.Rect) '黄色で塗りつぶし Else e.Graphics.FillRectangle(Brushes.Cyan, polygon.Rect) '水色で塗りつぶし End If e.Graphics.DrawRectangle(Pens.Blue, polygon.Rect) '青い枠線 Next If Control.MouseButtons <> MouseButtons.Left Then 'マウスの左ボタンが押されていない場合何もしない Return End If 'ドラッグを開始したマウスの位置(mouseDownPosition)と現在ドラッグ中のマウスの位置(mouseDragPosition) 'から、描画すべき四角形の座標を計算する。 Dim activeRect As Rectangle = CalcActiveRect(mouseDownPosition, mouseDragPosition) 'ドラッグ中の四角形を描画 e.Graphics.DrawRectangle(selectPen, activeRect) End Sub Private Function CalcActiveRect(startPosition As Point, endPosition As Point) As Rectangle Dim activeRect As New Rectangle activeRect.X = Math.Min(mouseDownPosition.X, mouseDragPosition.X) activeRect.Y = Math.Min(mouseDownPosition.Y, mouseDragPosition.Y) activeRect.Width = Math.Abs(mouseDragPosition.X - mouseDownPosition.X) activeRect.Height = Math.Abs(mouseDragPosition.Y - mouseDownPosition.Y) Return activeRect End Function Private Sub PictureBox1_MouseDown(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseDown 'マウスのボタンが押された場合、 mouseDownPosition = e.Location isMouseDown = True End Sub Private Sub PictureBox1_MouseMove(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseMove 'マウスを移動した場合 mouseDragPosition = e.Location PictureBox1.Invalidate() 'PictureBoxを強制的に再描画する End Sub Private Sub PictureBox1_MouseUp(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseUp 'マウスを離した場合 If isMouseDown = True Then Dim activeRect As Rectangle = Me.CalcActiveRect(mouseDownPosition, mouseDragPosition) If activeRect.Width * activeRect.Height > 0 Then '面積がある場合、この四角形を描画対象に追加する。 polygons.Add(New Polygon With {.Rect = activeRect}) Else '面積がない場合、これはクリックである。 Dim selectedPolygon As Polygon = Nothing 'クリックされた位置に四角形を存在するか調べる。 '※同じ位置に複数の四角形がある可能性があるので最後に見つかったものを '変数selectedPolygonにセットしておく。 For Each polygon In polygons polygon.IsSelected = False If polygon.Rect.Contains(e.Location) Then selectedPolygon = polygon End If Next '四角形があった場合、IsSelecteをTrueにしておく。 '→この目印があることで Paintイベント内で特別扱いする。 If selectedPolygon IsNot Nothing Then selectedPolygon.IsSelected = True End If End If isMouseDown = False End If PictureBox1.Invalidate() 'PictureBoxを強制的に再描画する End Sub End Class Public Class Polygon Public Property Rect As Rectangle Public Property IsSelected As Boolean End Class |
VB6ではPaintイベントではなく、マウスのイベント発生時などに直接描画処理を実行します。