トップ回答者
PictureBox を2層使用して 背景を表示したまま、マウスドラッグで四角形を表示したい

質問
-
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 のまま、
親コントロール指定も、変更されておりません。
どなたかご教授いただけないでしょうか。
回答
-
こんな
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月31日 1:54
すべての返信
-
こんな
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月31日 1:54