|
おそれいります。あと一歩だと思うのですが・・・
D&Dと組み合わせてみたのですが、上手く動きませんでした。。
何故か
ListBox1.Items.Add(part1) ' 画像の追加 ★★
のところから、
Sub ListBox1DrawItem
に飛んでしまうようです。で、処理はそこで終了してしまい、何も追加されません。
Debug.Print("drop!") の行まで行きません。。
（まずはSub ListBox1MeasureItem に行くはずでは・・・）
どうしてこうなってしまうのか・・・ずっと見比べているのですが、わかりません。。
なにか見落としがあると思うのですが、、、、
----
Public Partial Class MainForm
Const spacing As Integer = 3 ' 画像の周りのスペース
Const MaxItemHeight As Integer = 255 ' ItemHeightの最大値
Dim mouseDownPoint As Point
Public Sub New()
' The Me.InitializeComponent call is required for Windows Forms designer support.
Me.InitializeComponent()
pictureBox1.Load("cube001_a.gif")
End Sub
<DebuggerDisplay("txtの内容は「{txt}」です")> _
Class Parts
public txt As String
public icon As Image
Public Overrides Function ToString() As String
Return txt
End Function
End Class
' 幅w、高さh内に収まるようなImageオブジェクトを作成
Function createThumbnail(ByVal image As Image, ByVal w As Integer, ByVal h As Integer) As Image
Dim fw As Double = CDbl(w) / CDbl(image.Width)
Dim fh As Double = CDbl(h) / CDbl(image.Height)
Dim scale As Double = Math.Min(fw, fh)
Dim nw As Integer = CInt(image.Width * scale /2)
Dim nh As Integer = CInt(image.Height * scale /2)
Return New Bitmap(image, nw, nh)
End Function
Sub ListBox1DragEnter(sender As Object, e As DragEventArgs)
If e.Data.GetDataPresent(GetType(PictureBox)) Then
e.Effect = DragDropEffects.Copy
Debug.Print("enter")
Else
'picturebox型でなければ受け入れない
e.Effect = DragDropEffects.None
Debug.Print("NG")
End If
End Sub
Sub ListBox1DragDrop(sender As Object, e As DragEventArgs)
Debug.Print("drop IN")
'ドロップされたデータがPictureBox型か調べる
If e.Data.GetDataPresent(GetType(PictureBox)) Then
Debug.Print("drop IN 1")
Dim part1 As Parts = New Parts()
Dim target As ListBox = CType(sender, ListBox)
Dim pic As PictureBox = _
DirectCast(e.Data.GetData(GetType(PictureBox)), PictureBox)
'ドロップされたデータをリストボックスに追加する
Dim original As Image = pic.image
Debug.Print("test " & pic.ImageLocation)
Debug.Print("drop IN 2")
part1.icon = createThumbnail(original, _
ListBox1.ClientSize.Width - spacing * 2, _
MaxItemHeight - spacing * 2)
Debug.Print("drop IN 3")
ListBox1.Items.Add(part1) ' 画像の追加 ★★
Debug.Print("drop!")
End If
End Sub
Sub PictureBox1MouseDown(sender As Object, e As MouseEventArgs)
'マウスの左ボタンだけが押されている時のみドラッグできるようにする
If e.Button = MouseButtons.Left Then
'ドラッグの準備
Dim pic As PictureBox = DirectCast(sender, PictureBox)
'マウスの押された位置を記憶
mouseDownPoint = New Point(e.X, e.Y)
Else
mouseDownPoint = Point.Empty
End If
End Sub
Sub PictureBox1MouseMove(sender As Object, e As MouseEventArgs)
If mouseDownPoint <> Point.Empty Then
'ドラッグとしないマウスの移動範囲を取得する
Dim moveRect As New Rectangle(mouseDownPoint.X - SystemInformation.DragSize.Width / 2, mouseDownPoint.Y - SystemInformation.DragSize.Height / 2, SystemInformation.DragSize.Width, SystemInformation.DragSize.Height)
'ドラッグとする移動範囲を超えたか調べる
If Not moveRect.Contains(e.X, e.Y) Then
'ドラッグの準備
Dim pic As PictureBox = DirectCast(sender, PictureBox)
'ドラッグ&ドロップ処理を開始する
Dim dde As DragDropEffects = pic.DoDragDrop(Me.pictureBox1, DragDropEffects.Copy)
mouseDownPoint = Point.Empty
End If
End If
End Sub
Sub ListBox1MeasureItem(sender As Object, e As MeasureItemEventArgs)
Debug.Print("MeasureItem")
Dim thumbnail As Image = CType(ListBox1.Items(e.Index), Parts).icon
e.ItemHeight = thumbnail.Height + spacing * 2
End Sub
Sub ListBox1DrawItem(sender As Object, e As DrawItemEventArgs)
Debug.Print("DrawItem")
If e.Index = -1 Then ' 項目がない場合にも呼び出される
Return
End If
e.DrawBackground()
Dim thumbnail As Image = CType(ListBox1.Items(e.Index), Parts).icon
' 画像を中央に表示
e.Graphics.DrawImage(thumbnail, _
e.Bounds.X + (e.Bounds.Width - thumbnail.Width) \ 2, _
e.Bounds.Y + (e.Bounds.Height - thumbnail.Height) \ 2)
e.DrawFocusRectangle()
End Sub
End Class
|