I have a question about drag object and collision.
I can get when the dragged object get collided
with others object...but
how to stop drag when collide ?
I have a question about drag object and collision.
I can get when the dragged object get collided
with others object...but
how to stop drag when collide ?
Thanks for help
Nanni
You mean this:
Code:
Private Sub SomeObject_DragOver(Source As Control, X As Single, Y As Single, State As Integer)
Source.Drag 2
End Sub
I'm using BitBlt to Overlay a picture on another.
I have a Picturebox for destination and two Picturebox for
Keeping Sprite (1 for mask and 1 for complete image).
I'm using MouseMove for Drag image in destination PictureBox.
If PicSprite(ID1).Left <= PicSprite(ID2).Left + PicSprite(ID2).Width Then
If PicSprite(ID).Left + PicSprite(ID).Width >= PicSprite(ID2).Left Then
If PicSprite(ID).Top <= PicSprite(ID2).Top + PicSprite(ID2).Height Then
If PicSprite(ID).Top + PicSprite(ID).Height >= PicSprite(ID2).Top Then
Overlap = True
End If
End If
End If
End If
with others object, but I do not know how to stop the movement
of the object, when it comes into contact with anothers.
You were setting overlap to true but not to false, that was stopping you from completing the routine. I added a circular collision check - your smiley faces are oval so the cant come together completely. If they were round they would. You can un-Rem the rectagular collision.
Code:
Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Const MERGEPAINT = &HBB0226
Private Const SRCAND = &H8800C6
Private Const SRCCOPY = &HCC0020
Private Const SRCPAINT = &HEE0086
Private Type ObjectDataType
Id As Long 'ID identifies what image to associate with this object
X As Long 'X position (upper left corner) of the image within the Big picture
Y As Long 'Y position (upper left corner) of the image withing the Big picture
W As Long 'The Width of the Image
H As Long 'The Height of the Image
oldx As Long
oldy As Long
End Type
Private Type ObjectType 'To keep track of the images we want to drag around
Dat As ObjectDataType
PrvLink As Long 'Link to the next lower image
NxtLink As Long 'Link to the next higher image
End Type
Dim Obj(1 To 6) As ObjectType 'Create array to keep track of sprite
Dim dragObj As Long 'Holds the selected object (the one clicked on)
Dim mx As Single, my As Single 'holds the position of the mouseX and mouseY relative to the view window
Dim Px As Long, Py As Long 'holds the picture offset, used in scrolling the background
Dim Xoffset As Long, Yoffset As Long 'holds the relative offset of the mouse, within the image being moved
Dim sx As Single 'Scale factor to be applied to the viewport relative Mouse X,
Dim sy As Single 'Scale factor for Y
Dim Overlap As Boolean
Dim b_lblMouseDownY As Boolean
Dim b_lblMouseDownX As Boolean
Private Sub UpdatePicture()
'Limit the viewport mouse X and Y values to the viewport
If mx < 0 Then mx = 0
If mx > PicDest.ScaleWidth Then mx = PicDest.ScaleWidth
If my < 0 Then my = 0
If my > PicDest.ScaleHeight Then my = PicDest.ScaleHeight
Px = mx * sx 'Determine the BigPicture X offset
Py = my * sy 'And Y offset
'Bitblt the background picture to the viewport (from the offset position (px,py)
BitBlt PicDest.hdc, 0, 0, PicDest.ScaleWidth, PicDest.ScaleHeight, PicBack.hdc, Px, Py, vbSrcCopy
'For each image object
' Determine the Pictureboxes of the Image from the ID
' Bitblt the mask and sprite of the image from their picturebox to their position in the viewport
Dim i As Long, Id As Long
'i = FirstLink 'start at the bottom of the zorder
For i = 1 To 2
With Obj(i).Dat
BitBlt PicDest.hdc, .X - Px, .Y - Py, Picture3(0).ScaleWidth, Picture3(0).ScaleHeight, Picture3(1).hdc, 0, 0, SRCAND
BitBlt PicDest.hdc, .X - Px, .Y - Py, Picture3(0).ScaleWidth, Picture3(0).ScaleHeight, Picture3(0).hdc, 0, 0, SRCPAINT
End With
Next i
PicDest.Refresh 'Update the viewport to see the result of all our work
End Sub
Private Sub Form_Load()
Dim i As Integer
Label1.Caption = "No Drag"
sx = (PicBack.ScaleWidth - PicDest.ScaleWidth) / PicDest.ScaleWidth
sy = (PicBack.ScaleHeight - PicDest.ScaleHeight) / PicDest.ScaleHeight
For i = 1 To 2
With Obj(i).Dat
.H = Picture3(0).ScaleHeight 'Save the image Height
.W = Picture3(0).ScaleWidth 'Save the image Width
If i = 1 Then
.X = 10 '
.Y = 10 ' position the image
Else
.X = 100
.Y = 100
End If
End With
Next i
UpdatePicture 'Display the current state of the picture
End Sub
Private Sub Picdest_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> vbLeftButton Then Exit Sub
Dim i As Long 'temporary loop counter
Dim tx As Long, ty As Long 'translated X and Y (viewport X,Y to the Big Picture's X,Y)
tx = X + Px ' Convert viewport X to BigPicture X (add picture X offset
ty = Y + Py ' Convert viewport Y to BigPicture Y (add Picture Y offset)
For i = LBound(Obj) To UBound(Obj)
With Obj(i).Dat ' Reference the Data for the indexed object
'Rectangular bounds check
If tx > .X And tx < .X + .W Then ' If the click X is within the X bounds of the image
If ty > .Y And ty < .Y + .H Then ' If the click Y is winin the Y bounds of the image
Xoffset = tx - .X ' Compute the relative X position within the image
Yoffset = ty - .Y ' Compute the relative Y position within the image
' See if this point corresponds to
' a black point on the mask.
If Picture3(1).Point(Xoffset, Yoffset) = vbBlack Then
dragObj = i '
Exit For
End If
End If
End If
End With
Next i
End Sub
Private Sub Picdest_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
If Button <> vbLeftButton Then Exit Sub
If dragObj > 0 Then 'If we are currently moving an image
Label1.Caption = "drag Object " & dragObj
'Collision detection with
For i = LBound(Obj) To UBound(Obj)
Obj(dragObj).Dat.X = X + Px - Xoffset ' Update the images position
Obj(dragObj).Dat.Y = Y + Py - Yoffset
If Not dragObj = i Then
Dim nx As Single, ny As Single
Dim mx As Single, my As Single
Dim distance As Single
mx = Obj(dragObj).Dat.X + Obj(dragObj).Dat.W / 2
my = Obj(dragObj).Dat.Y + Obj(dragObj).Dat.H / 2
nx = Obj(i).Dat.X + Obj(i).Dat.W / 2
ny = Obj(i).Dat.Y + Obj(i).Dat.H / 2
distance = Int(Sqr((mx - nx) ^ 2 + (my - ny) ^ 2))
' If Obj(dragObj).Dat.X <= Obj(i).Dat.X + Obj(i).Dat.W And _
' Obj(dragObj).Dat.X + Obj(dragObj).Dat.W >= Obj(i).Dat.X And _
' Obj(dragObj).Dat.Y <= Obj(i).Dat.Y + Obj(i).Dat.H And _
' Obj(dragObj).Dat.Y + Obj(dragObj).Dat.H >= Obj(i).Dat.Y Then
If distance < Obj(dragObj).Dat.W Then
Overlap = True
Obj(dragObj).Dat.X = Obj(dragObj).Dat.oldx ' Update the images position
Obj(dragObj).Dat.Y = Obj(dragObj).Dat.oldy
Label2.Caption = "Overlap"
Debug.Print "Overlap", X, Y, i
Exit For
Else
Label2.Caption = "NO Overlap"
Overlap = False
Obj(dragObj).Dat.oldx = Obj(dragObj).Dat.X
Obj(dragObj).Dat.oldy = Obj(dragObj).Dat.Y
End If
End If
Next i
UpdatePicture
End If
End Sub
Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownY = True
End Sub
Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If b_lblMouseDownY And (Y / Screen.TwipsPerPixelY <= Image1.Height) And (Y / Screen.TwipsPerPixelY > 0) Then
my = (Y - PicDest.ScaleTop) / Screen.TwipsPerPixelY 'update the MouseY
UpdatePicture
End If
End Sub
Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownY = False
End Sub
Private Sub Image2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownX = True
End Sub
Private Sub Image2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If b_lblMouseDownX And (X / Screen.TwipsPerPixelX <= Image2.Width) And (X / Screen.TwipsPerPixelX > 0) Then
mx = (X - PicDest.ScaleLeft) / Screen.TwipsPerPixelX 'Image2.Left / Screen.TwipsPerPixelX
UpdatePicture
End If
End Sub
Private Sub Image2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownX = False
End Sub
Private Sub PicDest_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
dragObj = 0
End Sub
Test to see if the two positions of the images intersect using a simple function, then, as long as they intersect (at all), you can stop it from moving:
Code:
Type Rectangle
X As Integer
Y As Integer
Width As Integer
Height As Integer
End Type
Function Intersect(rect1 As Rectangle, rect2 As Rectangle) As Boolean
if (((rect1.X > (rect2.X + rect2.Width)) _
AND (rect2.X < (rect1.X + rect1.Width))) _
AND (rect1.Y < (rect2.Y + rect2.Height))) Then
Intersect = (rect2.Y < (rect1.Y + rect1.Height))
End If
Intersect = False
End Function
Use it like..
Code:
Dim picture1Position As Rectangle
Dim picture2Position As Rectangle
picture1Position.X = 50
picture1Position.Y = 50
picture1Position.Width = 300
picture1Position.Height = 300
picture2Position.X = 100
picture2Position.Y = 100
picture2Position.Width = 300
picture2Position.Height = 300
If Not (Intersect(picture1Position, picture2Position)) Then
' if these two rectangles do not overlap.. then move the image..
End If
I need to drag Sprite bitblt to a BackGround.
I can drag sprite, i can check for collision (also Pixel Collision)
but I can't get always the same overlap point.
Use the arrow keys to move the sprite is quite simple,
but I do not understand how to achieve the same result
using the mouse for dragging sprite.
When you drag quickly the sprite, the overlap point
is not the same as when you drag the sprite slowly.
Is there a workaround for this behaviour?
That's actually a pretty simple resolution. I'm not by my computer right now but I will explain and later I can give you an example.
When 2 circles are adjacent the line segment created by their centers is always the length of 1 circles diameter. To find the known distance from one center to the other you perform the Pythagorean Theorem (a^2 +b^2= c^2).
Knowing the length of the hypotenuse you can cross multiply to find the x and y of the adjacent circle.
OK, here it is. I'm 100% sure this is what your looking for.
If the balls were a perfect circle they'd butt up to each other perfectly but since theyre oval there will always be a slight gap. I uploaded some perfectly round ones for you.
Code:
Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Const MERGEPAINT = &HBB0226
Private Const SRCAND = &H8800C6
Private Const SRCCOPY = &HCC0020
Private Const SRCPAINT = &HEE0086
Private Type ObjectDataType
Id As Long 'ID identifies what image to associate with this object
X As Long 'X position (upper left corner) of the image within the Big picture
Y As Long 'Y position (upper left corner) of the image withing the Big picture
W As Long 'The Width of the Image
H As Long 'The Height of the Image
oldx As Long
oldy As Long
End Type
Private Type ObjectType 'To keep track of the images we want to drag around
Dat As ObjectDataType
PrvLink As Long 'Link to the next lower image
NxtLink As Long 'Link to the next higher image
End Type
Dim Obj(1 To 6) As ObjectType 'Create array to keep track of sprite
Dim dragObj As Long 'Holds the selected object (the one clicked on)
Dim mx As Single, my As Single 'holds the position of the mouseX and mouseY relative to the view window
Dim Px As Long, Py As Long 'holds the picture offset, used in scrolling the background
Dim Xoffset As Long, Yoffset As Long 'holds the relative offset of the mouse, within the image being moved
Dim sx As Single 'Scale factor to be applied to the viewport relative Mouse X,
Dim sy As Single 'Scale factor for Y
Dim Overlap As Boolean
Dim b_lblMouseDownY As Boolean
Dim b_lblMouseDownX As Boolean
Private Sub UpdatePicture()
'Limit the viewport mouse X and Y values to the viewport
If mx < 0 Then mx = 0
If mx > PicDest.ScaleWidth Then mx = PicDest.ScaleWidth
If my < 0 Then my = 0
If my > PicDest.ScaleHeight Then my = PicDest.ScaleHeight
Px = mx * sx 'Determine the BigPicture X offset
Py = my * sy 'And Y offset
'Bitblt the background picture to the viewport (from the offset position (px,py)
BitBlt PicDest.hdc, 0, 0, PicDest.ScaleWidth, PicDest.ScaleHeight, PicBack.hdc, Px, Py, vbSrcCopy
'For each image object
' Determine the Pictureboxes of the Image from the ID
' Bitblt the mask and sprite of the image from their picturebox to their position in the viewport
Dim i As Long, Id As Long
'i = FirstLink 'start at the bottom of the zorder
For i = 1 To 2
With Obj(i).Dat
BitBlt PicDest.hdc, .X - Px, .Y - Py, Picture3(0).ScaleWidth, Picture3(0).ScaleHeight, Picture3(1).hdc, 0, 0, SRCAND
BitBlt PicDest.hdc, .X - Px, .Y - Py, Picture3(0).ScaleWidth, Picture3(0).ScaleHeight, Picture3(0).hdc, 0, 0, SRCPAINT
End With
Next i
PicDest.Refresh 'Update the viewport to see the result of all our work
End Sub
Private Sub Form_Load()
Dim i As Integer
Label1.Caption = "No Drag"
sx = (PicBack.ScaleWidth - PicDest.ScaleWidth) / PicDest.ScaleWidth
sy = (PicBack.ScaleHeight - PicDest.ScaleHeight) / PicDest.ScaleHeight
For i = 1 To 2
With Obj(i).Dat
.H = Picture3(0).ScaleHeight 'Save the image Height
.W = Picture3(0).ScaleWidth 'Save the image Width
If i = 1 Then
.X = 10 '
.Y = 10 ' position the image
Else
.X = 100
.Y = 100
End If
End With
Next i
UpdatePicture 'Display the current state of the picture
End Sub
Private Sub Picdest_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> vbLeftButton Then Exit Sub
Dim i As Long 'temporary loop counter
Dim tx As Long, ty As Long 'translated X and Y (viewport X,Y to the Big Picture's X,Y)
tx = X + Px ' Convert viewport X to BigPicture X (add picture X offset
ty = Y + Py ' Convert viewport Y to BigPicture Y (add Picture Y offset)
For i = LBound(Obj) To UBound(Obj)
With Obj(i).Dat ' Reference the Data for the indexed object
'Rectangular bounds check
If tx > .X And tx < .X + .W Then ' If the click X is within the X bounds of the image
If ty > .Y And ty < .Y + .H Then ' If the click Y is winin the Y bounds of the image
Xoffset = tx - .X ' Compute the relative X position within the image
Yoffset = ty - .Y ' Compute the relative Y position within the image
' See if this point corresponds to
' a black point on the mask.
If Picture3(1).Point(Xoffset, Yoffset) = vbBlack Then
dragObj = i '
Exit For
End If
End If
End If
End With
Next i
End Sub
Private Sub Picdest_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
If Button <> vbLeftButton Then Exit Sub
If dragObj > 0 Then 'If we are currently moving an image
Label1.Caption = "drag Object " & dragObj
'Collision detection with
For i = LBound(Obj) To UBound(Obj)
With Obj(dragObj).Dat
.X = X + Px - Xoffset ' Update the images position
.Y = Y + Py - Yoffset
End With
If Not dragObj = i Then
Dim nx As Single, ny As Single
Dim mx As Single, my As Single
Dim distance As Single
mx = Obj(dragObj).Dat.X + Obj(dragObj).Dat.W / 2
my = Obj(dragObj).Dat.Y + Obj(dragObj).Dat.H / 2
nx = Obj(i).Dat.X + Obj(i).Dat.W / 2
ny = Obj(i).Dat.Y + Obj(i).Dat.H / 2
distance = Int(Sqr((mx - nx) ^ 2 + (my - ny) ^ 2))
' If Obj(dragObj).Dat.X <= Obj(i).Dat.X + Obj(i).Dat.W And _
' Obj(dragObj).Dat.X + Obj(dragObj).Dat.W >= Obj(i).Dat.X And _
' Obj(dragObj).Dat.Y <= Obj(i).Dat.Y + Obj(i).Dat.H And _
' Obj(dragObj).Dat.Y + Obj(dragObj).Dat.H >= Obj(i).Dat.Y Then
If distance < Obj(dragObj).Dat.W Then
Overlap = True
With Obj(dragObj).Dat
.X = .W * (mx - nx) / distance + nx - Obj(dragObj).Dat.W / 2
.Y = .W * (my - ny) / distance + ny - Obj(dragObj).Dat.W / 2
End With
Label2.Caption = "Overlap"
Debug.Print "Overlap", X, Y, i
Exit For
Else
Label2.Caption = "NO Overlap"
Overlap = False
Obj(dragObj).Dat.oldx = Obj(dragObj).Dat.X
Obj(dragObj).Dat.oldy = Obj(dragObj).Dat.Y
End If
End If
Next i
UpdatePicture
End If
End Sub
Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownY = True
End Sub
Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If b_lblMouseDownY And (Y / Screen.TwipsPerPixelY <= Image1.Height) And (Y / Screen.TwipsPerPixelY > 0) Then
my = (Y - PicDest.ScaleTop) / Screen.TwipsPerPixelY 'update the MouseY
UpdatePicture
End If
End Sub
Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownY = False
End Sub
Private Sub Image2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownX = True
End Sub
Private Sub Image2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If b_lblMouseDownX And (X / Screen.TwipsPerPixelX <= Image2.Width) And (X / Screen.TwipsPerPixelX > 0) Then
mx = (X - PicDest.ScaleLeft) / Screen.TwipsPerPixelX 'Image2.Left / Screen.TwipsPerPixelX
UpdatePicture
End If
End Sub
Private Sub Image2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownX = False
End Sub
Private Sub PicDest_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
dragObj = 0
End Sub
Last edited by technorobbo; Mar 17th, 2009 at 05:45 PM.
hi technorobbo
your explanations are always very clear and precise.
The code works fine only when there are 2 objects.
Testing the code with 3 objects, the collision is
detected only for the first collided object.
I changed the code to have 3 objects.
Try to bring 2 object so that their distance is
smaller than the size of the third object.
When the third object comes into collision
with an object, it overlaps with another.
Code:
Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Const MERGEPAINT = &HBB0226
Private Const SRCAND = &H8800C6
Private Const SRCCOPY = &HCC0020
Private Const SRCPAINT = &HEE0086
Private Type ObjectDataType
Id As Long 'ID identifies what image to associate with this object
X As Long 'X position (upper left corner) of the image within the Big picture
Y As Long 'Y position (upper left corner) of the image withing the Big picture
W As Long 'The Width of the Image
H As Long 'The Height of the Image
oldx As Long
oldy As Long
End Type
Private Type ObjectType 'To keep track of the images we want to drag around
Dat As ObjectDataType
PrvLink As Long 'Link to the next lower image
NxtLink As Long 'Link to the next higher image
End Type
Dim Obj(1 To 3) As ObjectType 'Create array to keep track of sprite
Dim dragObj As Long 'Holds the selected object (the one clicked on)
Dim mx As Single, my As Single 'holds the position of the mouseX and mouseY relative to the view window
Dim Px As Long, Py As Long 'holds the picture offset, used in scrolling the background
Dim Xoffset As Long, Yoffset As Long 'holds the relative offset of the mouse, within the image being moved
Dim sx As Single 'Scale factor to be applied to the viewport relative Mouse X,
Dim sy As Single 'Scale factor for Y
Dim Overlap As Boolean
Dim b_lblMouseDownY As Boolean
Dim b_lblMouseDownX As Boolean
Private Sub UpdatePicture()
'Limit the viewport mouse X and Y values to the viewport
If mx < 0 Then mx = 0
If mx > picDest.ScaleWidth Then mx = picDest.ScaleWidth
If my < 0 Then my = 0
If my > picDest.ScaleHeight Then my = picDest.ScaleHeight
Px = mx * sx 'Determine the BigPicture X offset
Py = my * sy 'And Y offset
'Bitblt the background picture to the viewport (from the offset position (px,py)
BitBlt picDest.hdc, 0, 0, picDest.ScaleWidth, picDest.ScaleHeight, PicBack.hdc, Px, Py, vbSrcCopy
'For each image object
' Determine the Pictureboxes of the Image from the ID
' Bitblt the mask and sprite of the image from their picturebox to their position in the viewport
Dim i As Long, Id As Long
'i = FirstLink 'start at the bottom of the zorder
For i = LBound(Obj) To UBound(Obj)
With Obj(i).Dat
BitBlt picDest.hdc, .X - Px, .Y - Py, Picture3(0).ScaleWidth, Picture3(0).ScaleHeight, Picture3(1).hdc, 0, 0, SRCAND
BitBlt picDest.hdc, .X - Px, .Y - Py, Picture3(0).ScaleWidth, Picture3(0).ScaleHeight, Picture3(0).hdc, 0, 0, SRCPAINT
End With
Next i
picDest.Refresh 'Update the viewport to see the result of all our work
End Sub
Private Sub Form_Load()
Dim i As Integer
Label1.Caption = "No Drag"
sx = (PicBack.ScaleWidth - picDest.ScaleWidth) / picDest.ScaleWidth
sy = (PicBack.ScaleHeight - picDest.ScaleHeight) / picDest.ScaleHeight
For i = LBound(Obj) To UBound(Obj)
With Obj(i).Dat
.H = Picture3(0).ScaleHeight 'Save the image Height
.W = Picture3(0).ScaleWidth 'Save the image Width
If i = 1 Then
.X = 10 '
.Y = 10 ' position the image
ElseIf i = 2 Then
.X = 100
.Y = 100
Else
.X = 100
.Y = 200
End If
End With
Next i
UpdatePicture 'Display the current state of the picture
End Sub
Private Sub Picdest_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> vbLeftButton Then Exit Sub
Dim i As Long 'temporary loop counter
Dim tx As Long, ty As Long 'translated X and Y (viewport X,Y to the Big Picture's X,Y)
tx = X + Px ' Convert viewport X to BigPicture X (add picture X offset
ty = Y + Py ' Convert viewport Y to BigPicture Y (add Picture Y offset)
For i = LBound(Obj) To UBound(Obj)
With Obj(i).Dat ' Reference the Data for the indexed object
'Rectangular bounds check
If tx > .X And tx < .X + .W Then ' If the click X is within the X bounds of the image
If ty > .Y And ty < .Y + .H Then ' If the click Y is winin the Y bounds of the image
Xoffset = tx - .X ' Compute the relative X position within the image
Yoffset = ty - .Y ' Compute the relative Y position within the image
' See if this point corresponds to
' a black point on the mask.
If Picture3(1).Point(Xoffset, Yoffset) = vbBlack Then
dragObj = i '
Exit For
End If
End If
End If
End With
Next i
End Sub
Private Sub Picdest_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
If Button <> vbLeftButton Then Exit Sub
If dragObj > 0 Then 'If we are currently moving an image
Label1.Caption = "drag Object " & dragObj
'Collision detection with
For i = LBound(Obj) To UBound(Obj)
With Obj(dragObj).Dat
.X = X + Px - Xoffset ' Update the images position
.Y = Y + Py - Yoffset
End With
If Not dragObj = i Then
Dim nx As Single, ny As Single
Dim mx As Single, my As Single
Dim distance As Single
mx = Obj(dragObj).Dat.X + Obj(dragObj).Dat.W / 2
my = Obj(dragObj).Dat.Y + Obj(dragObj).Dat.H / 2
nx = Obj(i).Dat.X + Obj(i).Dat.W / 2
ny = Obj(i).Dat.Y + Obj(i).Dat.H / 2
distance = Int(Sqr((mx - nx) ^ 2 + (my - ny) ^ 2))
' If Obj(dragObj).Dat.X <= Obj(i).Dat.X + Obj(i).Dat.W And _
' Obj(dragObj).Dat.X + Obj(dragObj).Dat.W >= Obj(i).Dat.X And _
' Obj(dragObj).Dat.Y <= Obj(i).Dat.Y + Obj(i).Dat.H And _
' Obj(dragObj).Dat.Y + Obj(dragObj).Dat.H >= Obj(i).Dat.Y Then
If distance < Obj(dragObj).Dat.W Then
Overlap = True
With Obj(dragObj).Dat
.X = .W * (mx - nx) / distance + nx - Obj(dragObj).Dat.W / 2
.Y = .W * (my - ny) / distance + ny - Obj(dragObj).Dat.W / 2
End With
Label2.Caption = "Overlap"
Debug.Print "Overlap", X, Y, i
Exit For
Else
Label2.Caption = "NO Overlap"
Overlap = False
Obj(dragObj).Dat.oldx = Obj(dragObj).Dat.X
Obj(dragObj).Dat.oldy = Obj(dragObj).Dat.Y
End If
End If
Next i
UpdatePicture
End If
End Sub
Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownY = True
End Sub
Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If b_lblMouseDownY And (Y / Screen.TwipsPerPixelY <= Image1.Height) And (Y / Screen.TwipsPerPixelY > 0) Then
my = (Y - picDest.ScaleTop) / Screen.TwipsPerPixelY 'update the MouseY
UpdatePicture
End If
End Sub
Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownY = False
End Sub
Private Sub Image2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownX = True
End Sub
Private Sub Image2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If b_lblMouseDownX And (X / Screen.TwipsPerPixelX <= Image2.Width) And (X / Screen.TwipsPerPixelX > 0) Then
mx = (X - picDest.ScaleLeft) / Screen.TwipsPerPixelX 'Image2.Left / Screen.TwipsPerPixelX
UpdatePicture
End If
End Sub
Private Sub Image2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
b_lblMouseDownX = False
End Sub
Private Sub PicDest_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
dragObj = 0
End Sub
If your going to do multiple collisions then you'll need to do recursion. The logic is similar to a bubble sort.This is just the Picdest_MouseMove routine the rest can stay the same. The problem with recursion is that you have to protect from endless loop - a countdown or max number of loops will work. I haven't added that part - got no time right now ,but if you need help figuring it out just ask :
Code:
Private Sub Picdest_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim nx As Single, ny As Single
Dim mx As Single, my As Single
Dim distance As Single
Dim i As Integer
If Button <> vbLeftButton Then Exit Sub
If dragObj > 0 Then 'If we are currently moving an image
Label1.Caption = "drag Object " & dragObj
'Collision detection with
With Obj(dragObj).Dat
.X = X + Px - Xoffset ' Update the images position
.Y = Y + Py - Yoffset
End With
Do
Overlap = False
For i = LBound(Obj) To UBound(Obj)
If Not dragObj = i Then
mx = Obj(dragObj).Dat.X + Obj(dragObj).Dat.W / 2
my = Obj(dragObj).Dat.Y + Obj(dragObj).Dat.H / 2
nx = Obj(i).Dat.X + Obj(i).Dat.W / 2
ny = Obj(i).Dat.Y + Obj(i).Dat.H / 2
distance = Int(Sqr((mx - nx +.1) ^ 2 + (my - ny + .1 ) ^ 2))
' If Obj(dragObj).Dat.X <= Obj(i).Dat.X + Obj(i).Dat.W And _
' Obj(dragObj).Dat.X + Obj(dragObj).Dat.W >= Obj(i).Dat.X And _
' Obj(dragObj).Dat.Y <= Obj(i).Dat.Y + Obj(i).Dat.H And _
' Obj(dragObj).Dat.Y + Obj(dragObj).Dat.H >= Obj(i).Dat.Y Then
If distance < Obj(dragObj).Dat.W Then
Overlap = True
With Obj(dragObj).Dat
.X = .W * (mx - nx) / distance + nx - Obj(dragObj).Dat.W / 2
.Y = .W * (my - ny) / distance + ny - Obj(dragObj).Dat.W / 2
End With
Label2.Caption = "Overlap"
Debug.Print "Overlap", X, Y, i
Exit For
Else
Label2.Caption = "NO Overlap"
End If
End If
Next i
Loop While Overlap
UpdatePicture
End If
End Sub
Post Edit : You should also a global flag used as a semaphore to prohibit multiple events while the routine is processing.
added a +.1 to avoid a div by 0 error
Last edited by technorobbo; Mar 18th, 2009 at 10:23 AM.
Private Sub Picdest_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim nx As Single, ny As Single
Dim mx As Single, my As Single
Dim distance As Single, countdown As Integer
Dim i As Integer
If Button <> vbLeftButton Then Exit Sub
If dragObj > 0 Then 'If we are currently moving an image
Label1.Caption = "drag Object " & dragObj
'Collision detection with
With Obj(dragObj).Dat
.X = X + Px - Xoffset ' Update the images position
.Y = Y + Py - Yoffset
End With
countdown = 10
Do
Overlap = False
For i = LBound(Obj) To UBound(Obj)
If Not dragObj = i Then
mx = Obj(dragObj).Dat.X + Obj(dragObj).Dat.W / 2
my = Obj(dragObj).Dat.Y + Obj(dragObj).Dat.H / 2
nx = Obj(i).Dat.X + Obj(i).Dat.W / 2
ny = Obj(i).Dat.Y + Obj(i).Dat.H / 2
distance = Int(Sqr((mx - nx) ^ 2 + (my - ny) ^ 2)) + 0.001
' If Obj(dragObj).Dat.X <= Obj(i).Dat.X + Obj(i).Dat.W And _
' Obj(dragObj).Dat.X + Obj(dragObj).Dat.W >= Obj(i).Dat.X And _
' Obj(dragObj).Dat.Y <= Obj(i).Dat.Y + Obj(i).Dat.H And _
' Obj(dragObj).Dat.Y + Obj(dragObj).Dat.H >= Obj(i).Dat.Y Then
If distance < Obj(dragObj).Dat.W Then
Overlap = True
With Obj(dragObj).Dat
.X = .W * (mx - nx) / distance + nx - Obj(dragObj).Dat.W / 2
.Y = .W * (my - ny) / distance + ny - Obj(dragObj).Dat.W / 2
End With
Label2.Caption = "Overlap"
Debug.Print "Overlap", X, Y, i
Exit For
Else
Label2.Caption = "NO Overlap"
End If
End If
Next i
countdown = countdown - 1
Loop While Overlap And countdown
UpdatePicture
End If
End Sub
I also moved the .o1 offset to the distance variable - works better!
I'm also wondering how this game will work, It very unique in it's design..
Last edited by technorobbo; Mar 18th, 2009 at 06:33 PM.