Ayuda, Drag & Drop

[sebah97]

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)



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  ).

Si precisan el codigo de como dibujé los cuadrados se los paso:

Código (vb) [Seleccionar] Expandir

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  (igual ni idea yo :S)

[BlackZeroX]

.
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!¡.
.

[EddyW]

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

Código [Seleccionar] Expandir

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:

Código [Seleccionar] Expandir

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!!!

[BlackZeroX]

.
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:

Código (vb) [Seleccionar] Expandir



'
' /////////////////////////////////////////////////////////////
' // 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!¡.
.

[sebah97]

gracias a los 2 por las respuestas