'元スレッド 'http://hpcgi1.nifty.com/MADIA/VBBBS2/wwwlng.cgi?print+201002/10020004.txt ' 'ボタンを 4 つ貼っておく Public Class Form1 Private Sub Form1_Load(ByVal sender As Object, _ ByVal e As EventArgs) Handles MyBase.Load Button1.AllowDrop = True Button2.AllowDrop = True Button3.AllowDrop = True Button4.AllowDrop = True Button1.Text = "A" Button2.Text = "B" Button3.Text = "C" Button4.Text = "D" End Sub #Region "ドラッグ側の操作" Private NoDragArea As Rectangle = Rectangle.Empty Private MousePoint As Point Private Sub btn_MouseDown(ByVal sender As Object, _ ByVal e As MouseEventArgs) Handles _ Button1.MouseDown, Button2.MouseDown, _ Button3.MouseDown, Button4.MouseDown If e.Button = MouseButtons.Left Then Dim sz As Size = SystemInformation.DragSize MousePoint = e.Location NoDragArea = New Rectangle(e.X, e.Y, sz.Width \ 2, sz.Height \ 2) End If End Sub Private Sub btn_MouseMove(ByVal sender As Object, _ ByVal e As MouseEventArgs) Handles _ Button1.MouseMove, Button2.MouseMove, _ Button3.MouseMove, Button4.MouseMove If NoDragArea.IsEmpty OrElse NoDragArea.Contains(e.Location) Then Return End If Dim btn As Button = DirectCast(sender, Button) Dim f As New DragForm(btn, MousePoint) f.Show(Me) btn.Hide() btn.DoDragDrop(sender, DragDropEffects.Move) f.Close() btn.Show() btn.FlatStyle = FlatStyle.Standard MousePoint = Point.Empty NoDragArea = Rectangle.Empty End Sub #End Region #Region "ドロップ側の操作" Private Sub btn_DragEnter(ByVal sender As Object, _ ByVal e As DragEventArgs) Handles _ Button1.DragEnter, Button2.DragEnter, _ Button3.DragEnter, Button4.DragEnter If e.Data.GetDataPresent(GetType(Button)) Then If e.Data.GetData(GetType(Button)) Is sender Then e.Effect = DragDropEffects.None Else e.Effect = DragDropEffects.Move DirectCast(sender, Button).FlatStyle = FlatStyle.Popup End If End If End Sub Private Sub btn_DragLeave(ByVal sender As Object, _ ByVal e As EventArgs) Handles _ Button1.DragLeave, Button2.DragLeave, _ Button3.DragLeave, Button4.DragLeave DirectCast(sender, Button).FlatStyle = FlatStyle.Standard End Sub Private Sub btn_DragDrop(ByVal sender As Object, _ ByVal e As DragEventArgs) Handles _ Button1.DragDrop, Button2.DragDrop, _ Button3.DragDrop, Button4.DragDrop Dim btn As Button = DirectCast(sender, Button) Dim source As Button = DirectCast(e.Data.GetData(GetType(Button)), Button) btn.FlatStyle = FlatStyle.Standard btn.Text = String.Format("({0})→[{1}]", source.Text, btn.Text) End Sub #End Region #Region "ドラッグ中の半透明アイテム" Private Class DragForm Inherits Form Private btn As Button Private offset As Size Private WithEvents tm As Timer Public Sub New(ByVal btn As Button, ByVal startLocation As Point) Me.offset = Point.Empty - startLocation Me.Location = Point.Empty Me.Size = Size.Empty Me.btn = btn Me.ControlBox = False Me.FormBorderStyle = System.Windows.Forms.FormBorderStyle.None Me.Opacity = 0.5 tm = New Timer() tm.Interval = 10 End Sub Protected Overrides Sub OnLoad(ByVal e As System.EventArgs) MyBase.OnLoad(e) Me.SetClientSizeCore(btn.Width, btn.Height) tm.Start() End Sub Protected Overrides ReadOnly Property CreateParams() As CreateParams Get Const WS_EX_TRANSPARENT As Integer = &H20 Dim cp As CreateParams = MyBase.CreateParams cp.ExStyle = cp.ExStyle Or WS_EX_TRANSPARENT Return cp End Get End Property Protected Overrides Sub OnPaint(ByVal e As PaintEventArgs) MyBase.OnPaint(e) Dim b As New Rectangle(0, 0, btn.Width, btn.Height) ButtonRenderer.DrawButton(e.Graphics, b, _ btn.Text, btn.Font, btn.Focused, _ VisualStyles.PushButtonState.Default) End Sub Protected Overrides Sub OnFormClosing(ByVal e As FormClosingEventArgs) tm.Stop() tm.Dispose() MyBase.OnFormClosing(e) End Sub Private Sub tm_Tick(ByVal sender As Object, ByVal e As System.EventArgs) Handles tm.Tick Location = MousePosition + offset End Sub End Class #End Region End Class