none
PictureBox を2層使用して 背景を表示したまま、マウスドラッグで四角形を表示したい RRS feed

  • 質問

  • OS: Windows 10 Pro
    開発環境: Visual Studio 2017
    プラットフォーム: VB.NET

    Windowsフォームで、PictureBoxを2つ使用して2層で、以下の実装を行いたいと考えています。
     1. 下のレイヤ: 画像表示
     2. 上のレイヤ: マウスドラッグで矩形を表示

    下のレイヤの画像を確認しながら、矩形を描きたいので、上のレイヤは透過させたいと
    考えています。

    しかし、以下、A、B それぞれ単独では実装に成功しているのですが、
     A. 上下2層を以下の通り同時に表示
      下のレイヤ: 画像表示
      上のレイヤ: 矩形をプログラム上で座標指定して表示

     B. 単独で PictureBoxにマウスドラッグで矩形を表示


    画像を表示させた後、マウスドラッグで矩形を描画しようとすると、
    背景画像が消えてしまいます。
    表示させたまま、マウスドラッグはどのように実装すればよいでしょうか。

    実装中のソース
    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
        Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
            '背景画像表示
            Dim bmpBase As Bitmap = New Bitmap("C:\tmp\picture\ppp.jpg")

            '下層のPictureBox 画像表示
            Me.pbxBase.Image = bmpBase

            '上層のPictureBox 親コントロール指定
            Me.pbxUpper.Parent = Me.pbxBase

            'サイズ、位置設定
            Me.pbxUpper.Size = Me.pbxBase.Size
            Me.pbxUpper.Location = New Point(0, 0)

            '描画用イメージオブジェクト作成
            Me._bmpUpper = New Bitmap(Me.pbxBase.Width, Me.pbxBase.Height)

            '透過色指定
            Me._bmpUpper.MakeTransparent(Color.White)

            '背景透過
            Me.pbxUpper.BackColor = Color.Transparent
        End Sub

        ''' <summary>
        ''' 上層PictureBox マウスダウン時イベント
        ''' </summary>
        Private Sub pbxUpper_MouseDown(sender As Object, e As MouseEventArgs) Handles pbxUpper.MouseDown
            Me._DrawFlg = True

            Me._PointMouseDown.X = e.X
            Me._PointMouseDown.Y = e.Y
        End Sub

        ''' <summary>
        ''' 上層PictureBox マウスアップ時イベント
        ''' </summary>
        Private Sub pbxUpper_MouseUp(sender As Object, e As MouseEventArgs) Handles pbxUpper.MouseUp
            Dim pointStart As Point = New Point()
            Dim pointEnd As Point = New Point()

            'MouseUp時の座標保存
            Me._PointMouseUp.X = e.X
            Me._PointMouseUp.Y = e.Y

            Me.GetRegion(Me._PointMouseDown, Me._PointMouseUp, pointStart, pointEnd)

            Me.DrawRegion(Me._bmpUpper, pointStart, pointEnd, Color.DarkCyan, Drawing2D.DashStyle.Solid)

            CType(sender, PictureBox).Image = Me._bmpUpper

            Me._DrawFlg = False
        End Sub

        ''' <summary>
        ''' 上層PictureBox マウス移動時イベント
        ''' </summary>
        Private Sub pbxUpper_MouseMove(sender As Object, e As MouseEventArgs) Handles pbxUpper.MouseMove
            Dim penCurrent As Point = New Point()
            Dim pointStart As Point = New Point()
            Dim pointEnd As Point = New Point()

            If Me._DrawFlg = False Then
                Return
            End If

            penCurrent.X = e.X
            penCurrent.Y = e.Y

            Me.GetRegion(Me._PointMouseDown, penCurrent, pointStart, pointEnd)

            Me.DrawRegion(Me._bmpUpper, pointStart, pointEnd, Color.DarkCyan, Drawing2D.DashStyle.Solid)

            CType(sender, PictureBox).Image = Me._bmpUpper
        End Sub
    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    マウス動作中の、上層PictureBoxのプロパティを確認しても、
    BackColor: Transparent のまま、
    親コントロール指定も、変更されておりません。

    どなたかご教授いただけないでしょうか。
    2019年1月30日 4:31

回答

  • こんな

    Option Strict On
    Public Class Form1
        Private _bmpUpper As Bitmap
        Private _PointMouseDown As Point
        Private _PointMouseUp As Point
        Private _DrawFlg As Boolean
        Private WithEvents pbxBase As PictureBox
        Private WithEvents pbxUpper As PictureBox
    
        Sub New()
    
            ' この呼び出しはデザイナーで必要です。
            InitializeComponent()
    
            ' InitializeComponent() 呼び出しの後で初期化を追加します。
            Me.Controls.Clear()
    
            pbxBase = New PictureBox() With {.SizeMode = PictureBoxSizeMode.StretchImage, .Left = 10, .Top = 10, .Width = Me.ClientSize.Width - 20, .Height = Me.ClientSize.Height - 20}
            pbxUpper = New PictureBox()
    
            Me.Controls.Add(pbxBase)
            Me.Controls.Add(pbxUpper)
    
        End Sub
    
        Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
            '背景画像表示
            Dim bmpBase As Bitmap = New Bitmap("ppp.jpg")
    
            '下層のPictureBox 画像表示
            Me.pbxBase.Image = bmpBase
    
            '上層のPictureBox 親コントロール指定
            Me.pbxUpper.Parent = Me.pbxBase
    
            'サイズ、位置設定
            Me.pbxUpper.Size = Me.pbxBase.Size
            Me.pbxUpper.Location = New Point(0, 0)
    
            '描画用イメージオブジェクト作成
            Me._bmpUpper = New Bitmap(Me.pbxBase.Width, Me.pbxBase.Height)
    
            '透過色指定
            Me._bmpUpper.MakeTransparent(Color.White)
    
            '背景透過
            Me.pbxUpper.BackColor = Color.Transparent
        End Sub
    
        ''' <summary>
        ''' 上層PictureBox マウスダウン時イベント
        ''' </summary>
        Private Sub pbxUpper_MouseDown(sender As Object, e As MouseEventArgs) Handles pbxUpper.MouseDown
            Me._DrawFlg = True
    
            Me._PointMouseDown.X = e.X
            Me._PointMouseDown.Y = e.Y
    
            Me._PointMouseUp.X = e.X
            Me._PointMouseUp.Y = e.Y
    
        End Sub
    
        ''' <summary>
        ''' 上層PictureBox マウスアップ時イベント
        ''' </summary>
        Private Sub pbxUpper_MouseUp(sender As Object, e As MouseEventArgs) Handles pbxUpper.MouseUp
            Draw(CType(sender, PictureBox), e)
            Me._DrawFlg = False
        End Sub
    
        ''' <summary>
        ''' 上層PictureBox マウス移動時イベント
        ''' </summary>
        Private Sub pbxUpper_MouseMove(sender As Object, e As MouseEventArgs) Handles pbxUpper.MouseMove
            If Me._DrawFlg = False Then
                Return
            End If
            Draw(CType(sender, PictureBox), e)
        End Sub
    
        Private Sub Draw(ByVal pb As PictureBox, ByVal e As MouseEventArgs)
            Dim penCurrent As Point = New Point()
            Dim pointStart As Point = New Point()
            Dim pointEnd As Point = New Point()
    
            penCurrent.X = e.X
            penCurrent.Y = e.Y
    
            Me.GetRegion(Me._PointMouseDown, penCurrent, pointStart, pointEnd)
            Me.DrawRegion(Me._bmpUpper, pointStart, pointEnd, Color.DarkCyan, Drawing2D.DashStyle.Solid)
    
            pb.Image = Me._bmpUpper
        End Sub
    
        Private Sub GetRegion(ByVal pdown As Point, ByVal pup As Point, ByRef pstart As Point, ByRef pend As Point)
            pstart = New Point(Math.Min(pdown.X, pup.X), Math.Min(pdown.Y, pup.Y))
            pend = New Point(Math.Max(pdown.X, pup.X), Math.Max(pdown.Y, pup.Y))
        End Sub
        Private Sub DrawRegion(ByVal bmp As Bitmap, ByVal pstart As Point, ByVal pend As Point, ByVal c As Color, ByVal dash As Drawing2D.DashStyle)
            Using g As Graphics = Graphics.FromImage(bmp)
                g.FillRectangle(Brushes.White, 0, 0, bmp.Width, bmp.Height)
    
                Dim pen As New Pen(New SolidBrush(c), 2)
                pen.DashStyle = dash
                Dim rectangle As Rectangle = New Rectangle(pstart.X, pstart.Y, pend.X - pstart.X, pend.Y - pstart.Y)
                g.DrawRectangle(pen, rectangle)
            End Using
            bmp.MakeTransparent(Color.White) 'これを忘れてる?
        End Sub
    End Clas

    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2019年1月30日 12:08

すべての返信

  • こんな

    Option Strict On
    Public Class Form1
        Private _bmpUpper As Bitmap
        Private _PointMouseDown As Point
        Private _PointMouseUp As Point
        Private _DrawFlg As Boolean
        Private WithEvents pbxBase As PictureBox
        Private WithEvents pbxUpper As PictureBox
    
        Sub New()
    
            ' この呼び出しはデザイナーで必要です。
            InitializeComponent()
    
            ' InitializeComponent() 呼び出しの後で初期化を追加します。
            Me.Controls.Clear()
    
            pbxBase = New PictureBox() With {.SizeMode = PictureBoxSizeMode.StretchImage, .Left = 10, .Top = 10, .Width = Me.ClientSize.Width - 20, .Height = Me.ClientSize.Height - 20}
            pbxUpper = New PictureBox()
    
            Me.Controls.Add(pbxBase)
            Me.Controls.Add(pbxUpper)
    
        End Sub
    
        Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
            '背景画像表示
            Dim bmpBase As Bitmap = New Bitmap("ppp.jpg")
    
            '下層のPictureBox 画像表示
            Me.pbxBase.Image = bmpBase
    
            '上層のPictureBox 親コントロール指定
            Me.pbxUpper.Parent = Me.pbxBase
    
            'サイズ、位置設定
            Me.pbxUpper.Size = Me.pbxBase.Size
            Me.pbxUpper.Location = New Point(0, 0)
    
            '描画用イメージオブジェクト作成
            Me._bmpUpper = New Bitmap(Me.pbxBase.Width, Me.pbxBase.Height)
    
            '透過色指定
            Me._bmpUpper.MakeTransparent(Color.White)
    
            '背景透過
            Me.pbxUpper.BackColor = Color.Transparent
        End Sub
    
        ''' <summary>
        ''' 上層PictureBox マウスダウン時イベント
        ''' </summary>
        Private Sub pbxUpper_MouseDown(sender As Object, e As MouseEventArgs) Handles pbxUpper.MouseDown
            Me._DrawFlg = True
    
            Me._PointMouseDown.X = e.X
            Me._PointMouseDown.Y = e.Y
    
            Me._PointMouseUp.X = e.X
            Me._PointMouseUp.Y = e.Y
    
        End Sub
    
        ''' <summary>
        ''' 上層PictureBox マウスアップ時イベント
        ''' </summary>
        Private Sub pbxUpper_MouseUp(sender As Object, e As MouseEventArgs) Handles pbxUpper.MouseUp
            Draw(CType(sender, PictureBox), e)
            Me._DrawFlg = False
        End Sub
    
        ''' <summary>
        ''' 上層PictureBox マウス移動時イベント
        ''' </summary>
        Private Sub pbxUpper_MouseMove(sender As Object, e As MouseEventArgs) Handles pbxUpper.MouseMove
            If Me._DrawFlg = False Then
                Return
            End If
            Draw(CType(sender, PictureBox), e)
        End Sub
    
        Private Sub Draw(ByVal pb As PictureBox, ByVal e As MouseEventArgs)
            Dim penCurrent As Point = New Point()
            Dim pointStart As Point = New Point()
            Dim pointEnd As Point = New Point()
    
            penCurrent.X = e.X
            penCurrent.Y = e.Y
    
            Me.GetRegion(Me._PointMouseDown, penCurrent, pointStart, pointEnd)
            Me.DrawRegion(Me._bmpUpper, pointStart, pointEnd, Color.DarkCyan, Drawing2D.DashStyle.Solid)
    
            pb.Image = Me._bmpUpper
        End Sub
    
        Private Sub GetRegion(ByVal pdown As Point, ByVal pup As Point, ByRef pstart As Point, ByRef pend As Point)
            pstart = New Point(Math.Min(pdown.X, pup.X), Math.Min(pdown.Y, pup.Y))
            pend = New Point(Math.Max(pdown.X, pup.X), Math.Max(pdown.Y, pup.Y))
        End Sub
        Private Sub DrawRegion(ByVal bmp As Bitmap, ByVal pstart As Point, ByVal pend As Point, ByVal c As Color, ByVal dash As Drawing2D.DashStyle)
            Using g As Graphics = Graphics.FromImage(bmp)
                g.FillRectangle(Brushes.White, 0, 0, bmp.Width, bmp.Height)
    
                Dim pen As New Pen(New SolidBrush(c), 2)
                pen.DashStyle = dash
                Dim rectangle As Rectangle = New Rectangle(pstart.X, pstart.Y, pend.X - pstart.X, pend.Y - pstart.Y)
                g.DrawRectangle(pen, rectangle)
            End Using
            bmp.MakeTransparent(Color.White) 'これを忘れてる?
        End Sub
    End Clas

    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2019年1月30日 12:08
  • gekka様

    ソース提示、ありがとうございました。
    意図した通りの動きとなりました。

    貴重なお時間、お手間をいただき、心より感謝申し上げます。

    追伸
    慌ててアップしてしまい、呼び出したメソッド内容を記述しておりませんでした。
    大変申し訳ありませんでした。


    2019年1月31日 1:52