Hola, como dice el titulo quisiera que me expliquen como puedo hacer Drag & Drop, pero no cualquiera,quisiera que lo haga de un Picturebox hasta una cuadricula dibujada con lineas (Ver Imagen)
(http://img130.imageshack.us/img130/5756/23123.png)
Como ven, quisiera que el picture que tiene cargada una Imagen verde copie esa Imagen al cuadrado que dibujé(Está Señalado con una Flecha, igual es un ejemplo, quisiera hacerlo con todos los cuadrados que quiera :xD).
Si precisan el codigo de como dibujé los cuadrados se los paso:
Sub Dibujar_cuadricula( _
Objeto As Object, _
CountX As Single, _
CountY As Single, _
Optional x_Color As Long = vbBlack, _
Optional y_Color As Long = vbBlack)
Dim i As Integer
Dim mx As Long
Dim my As Long
' limpiar objeto
Objeto.Cls
mx = CLng(Objeto.ScaleWidth / CountX)
my = CLng(Objeto.ScaleHeight / CountY)
Objeto.ForeColor = x_Color
For i = 0 To CountX
Objeto.Line (i * mx, 0)-(i * mx, Objeto.ScaleHeight)
Next i
Objeto.ForeColor = y_Color
For i = 0 To CountY
Objeto.Line (0, i * my)-(Objeto.ScaleWidth, i * my)
Next i
End Sub
Private Sub Form_Load()
With Picture1
.BackColor = vbWhite
.ForeColor = vbBlue
.FontSize = 12
.AutoRedraw = True
End With
' la cuadricula (osea los cuadraditos las dibuja en un picture grande (picture1 xd)
Call Dibujar_cuadricula(Picture1, 15, 15, vbRed, vbRed)
End Sub
PD: Para mi abria que hacer como algo para que cada cuadrado simule un CONTROL :xD (igual ni idea yo :S)
.
Espero que no busques códigos por que solo te soltare una idea
Yo en lugar de mover el picturebox dibujaría el contenido de este en las coordenas propuestas con el api BitBlt() teniendo el autoredraw=true para que no se borre el DC del control
Edito:
Tambien usa lo que es getcursosPos y ScreenToClient para que se te facilite el Drag &Drop
y por ultimo
IntersectRect para verificar la coordenada con respecto en las celdas para ver donde dibujar con el api BitBlt.
Nota: usa la estructura RECT si usas mi idea se te facilitara.
temibles Lunas!¡.
.
Creo que es mas simple aun..
Existe una forma mas sencilla de mover un control usando la API SendMessage:
Supongamos que quiero mover el Picture2 a mmm, algun lado XD
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" ( _
ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "User32" ()
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
Private Sub Picture2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ReleaseCapture
If Button = vbLeftButton Then
Call SendMessage(Picture2.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub
Con eso mueves el Picture2 a cualquier lado.., {al hacerle click y moverlo}
Ahora para que puedas arrastrar el Picture2 y otro control lo acepte debes de establecer su propiedad DragMode a Automático..
Supongamos que queremos arrastrar un Picture2 a un control de Picture1(0) {Picture1 sera una Matriz}
El Picture1 tiene un evento que se llama cada vez que se arrastra un 'algo' encima de este, el evento se llama DragDrop:
Private Sub Picture1_DragDrop(Index As Integer, Source As Control, X As Single, Y As Single)
MsgBox Index
End Sub
Si juntas todo el code.., al arrastrar el Picture2 a un control PIcture1 {Mas preciso a una Matriz de Picture1} te mostrara el Index del control al que haz arrastrado el picture2
Ahí ya tienes una idea, a partir de ahí es sencillo ;)
SaluDOS!!!
.
Espero te sirve este codigo que reaize hace tiempo es similar a lo que deseas solo que es una ilera xP
se nesesta:
1 picturebox llamado PIC con index = 0
1 Timer
En un formulario pegar:
'
' /////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este Codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandesido //
' // o achicado, si es en base a este codigo es requerido //
' // el agradacimiento al autor. //
' /////////////////////////////////////////////////////////////
'
Option Explicit
Private Declare Function IntersectRect Lib "user32" (lpDestRect As Rect, lpSrc1Rect As Rect, lpSrc2Rect As Rect) As Long
Private Type Rect
left As Long
top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
'Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
Dim lBtActual As Integer
Dim By As Long
'Dim Bx As Long
Const Anchura As Long = 80
Const Altura As Long = 20
Const CantZones As Integer = 10
Dim PostR() As Rect
Private Sub Form_Load()
Dim i As Integer
ReDimPostR (CantZones - 1)
ScaleMode = 3
For i = 0 To CantZones - 1
If i > 0 Then
Load Pic(i)
Pic(i).Visible = True
End If
' // Estas Son las Regiones
With PostR(i)
.left = 25
If i = 0 Then
.top = 25
Else
.top = PostR(i - 1).Bottom + 25
End If
.Right = .left + Anchura
.Bottom = .top + Altura
End With
' // Posicionamos los Label en las Regiones
Call PosPic(i)
Next i
Timer1.Interval = 20
Timer1.Enabled = False
End Sub
Private Sub pic_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim PT As POINTAPI
PosPic Index ' // Actualizamos la region
GetCursorPos PT
ScreenToClient hwnd, PT
By = PT.Y - Pic(Index).top
'Bx = PT.X - pic(Index).left
lBtActual = Index
Timer1.Enabled = True
End Sub
Private Sub pic_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
PosPic Index ' // Actualizamos la region
Timer1.Enabled = False
End Sub
Private Sub Timer1_Timer()
Dim PT As POINTAPI
Dim Rect(2) As Rect
Dim i As Integer
Dim AreCambio As Integer
GetCursorPos PT
ScreenToClient hwnd, PT
With Pic(lBtActual)
.Visible = True
'.left = PT.X - Bx
.top = PT.Y - By
.Visible = True
End With
With Rect(2)
' // Calculamos el Area de Cambio
AreCambio = (Altura / 2) - IIf(Altura < 10, 0, 10)
.top = Pic(lBtActual).top + AreCambio
.left = Pic(lBtActual).left
.Right = Pic(lBtActual).left + Pic(lBtActual).Width
.Bottom = Pic(lBtActual).top + Pic(lBtActual).Height - AreCambio
End With
For i = 0 To CantZones - 1
If lBtActual <> i And _
IntersectRect(Rect(0), Rect(2), PostR(i)) Then
Rect(0) = PostR(lBtActual) ' // Hacemos un Respaldo
PostR(lBtActual) = PostR(i)
PostR(i) = Rect(0)
Call PosPic(i)
Call PosPic(lBtActual)
Exit For
End If
Next i
End Sub
Private Sub PosPic(ByVal i As Integer)
With Pic(i)
.left = PostR(i).left
.BackColor = RGB(255 / (i + 1), 255 / (i + 1), 255 / (i + 1))
If i = 0 Then
.top = PostR(i).top
Else
.top = PostR(i).top
.top = .top
End If
.Width = PostR(i).Right - PostR(i).left
.Height = PostR(i).Bottom - PostR(i).top
End With
End Sub
Temibles Lunas!¡.
.
gracias a los 2 por las respuestas :)