ヘッダー
Visual Basic サンプル集
VB2005対応 VB2008対応 VB2010対応 VB2012対応 VB2013対応 VB2015対応 VB2017対応 VB2019対応

Visual Basic 中学校 > Visual Basic サンプル集 > Visual Basic サンプル集目次 > Windows フォーム >

マウス操作で図形を描画する

2020/12/20

→ C# のサンプルに切り替える

目次

 

このページで紹介するサンプルは Windowsフォームアプリケーションを前提にしています。

 

マウスをクリックした位置に次々と赤い線を描画する

この例はマウスでPictureBoxをクリックするたびに、その場所から、PiuctureBoxの左上に向けて線を次々と追加します。

VB2005対応 VB2008対応 VB2010対応 VB2012対応 VB2013対応 VB2015対応 VB2017対応 VB2019対応

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)が１つ配置されていることが前提です。

マウスで絵を描く

VB2008対応 VB2010対応 VB2012対応 VB2013対応 VB2015対応 VB2017 VB2019

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

メモ：初級講座(改訂版) 第１７回でこのプログラムが登場します。

 

 

 

マウスをなぞった位置にリアルタイムに四角形を描画する

この例はマウスでなぞった位置に四角形を描画します。

フォームにPictureBox(PictureBox1)が１つ配置されていることが前提です。

マウスでなぞった位置に四角形を描画

VB2005対応 VB2008対応 VB2010対応 VB2012対応 VB2013対応 VB2015対応 VB2017対応 VB2019対応

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)が１つ配置されていることが前提です。

マウスでなぞった位置に四角形を追加する

VB2008対応 VB2010対応 VB2012対応 VB2013対応 VB2015対応 VB2017対応 VB2019対応

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)が１つ配置されていることが前提です。

マウスでクリックした四角形の色が変わる

VB2008対応 VB2010対応 VB2012対応 VB2013対応 VB2015対応 VB2017対応 VB2019対応

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対応 VB6ではPaintイベントではなく、マウスのイベント発生時などに直接描画処理を実行します。