Animate Pic

[Dixie77]

Hi All,

I've been asked to devise a basic snakes and ladders game for a bit of fun in the office and I've got most of the code sorted (thanks to people on here and the internet )

But I've come up against a little problem, due to the number of people who will be using the game (9 people) I need a way to move their individual pictures around the board, I initially thought using different colour's within conditional formatting would work but this is only good for 3 people

Is it possible to move the pictures ??

Any help would be great,

Rob

 

[erik.van.geit]

Hi,
It is possible to move pictures within Excel using VBA.
Your question is quite vague though, perhaps not for those who helped you previsouly.
How do you want those pics to be moved?
kind regards,
Erik

 

[Dixie77]

Hi Erik,

Apologies for being vague,

I have the following code that will move the coloured square around the board (with conditional formatting)

Private Sub ButtonRob_Click()
'Roll the dice
Dim v As Integer
Dim cv As Integer
Dim NewTotal As Integer

v = Roll
cv = Cells(8, 16).Value

Range("M1:O3").Select
Selection.Font.ColorIndex = 4
Cells(1, 13) = v

NewTotal = cv + v
If NewTotal > 100 Then Exit Sub
Do
cv = cv + 1
Cells(8, 16) = cv
Loop Until cv = NewTotal

Cells(8, 16) = NewTotal
Cells(8, 16) = SnakesLadders(NewTotal)

If NewTotal = 100 Then
Cells(1, 13) = "WIN"
Cells(9, 16) = Cells(9, 16) + 1
End If
End Sub

I'm looking to achieve a similar outcome but substituting the coloured square for a picture, if possible

Thanks for you help

Rob

 

[erik.van.geit]

Create a shape, whatever you want.
Name it MyPic
Then try this code

Sub test()
Dim i As Long
With ActiveSheet.Shapes("MyPic")
    For i = 20 To 150
    .Top = i
    .Left = -i + 300
    DoEvents
    Next i
End With
End Sub

You can "connect" to cells using
Range("A1").Top
see also width and height properties

 

[Dixie77]

Hi Erik,

Thanks a lot for your help, I''l try the code tomorrow and let you know how I go.

Thanks again,

Rob

 

[erik.van.geit]

OK. In this case it could be useful to upload the workbook somewhere.
But first you can experiment a bit.

 

[erik.van.geit]

This code is far from behaving correctly. There are logical errors.
But it gives an idea how you could proceed and what criteria you need to take care of.

Option Explicit
Sub test()
Call GlidePicBetweenCells(ActiveSheet.Shapes("MyPic"), Range("C2"), Range("H8"), 0.3)
End Sub

Sub GlidePicBetweenCells(Pic As Shape, StartCell As Range, EndCell As Range, StepLenght As Single)
Dim StartTop As Single
Dim StartLeft As Single
Dim EndTop As Single
Dim EndLeft As Single
Dim MoveToLeftRatio As Single

Dim i As Single
Dim j As Long

    With StartCell
    StartTop = .Top
    StartLeft = .Left
    End With
    
    With EndCell
    EndTop = .Top
    EndLeft = .Left
    End With

    If EndTop = StartTop Then
    StepLenght = StepLenght / 50
    StartTop = StartTop - 0.01
    End If

    If EndTop < StartTop Then StepLenght = -StepLenght
    MoveToLeftRatio = (EndTop - StartTop) / (EndLeft - StartLeft)

    With Pic
    Application.ScreenUpdating = False
    .Top = StartTop
    .Left = StartLeft
    Application.ScreenUpdating = True
        For i = StartTop To EndTop Step StepLenght
        .Top = i
        .Left = StartLeft + MoveToLeftRatio * i
        j = j + 1
        DoEvents
        Next i
    .Top = EndTop
    .Left = EndLeft
    End With
End Sub

 

[erik.van.geit]

Couldn't forget this game
This seems quite satisfactory to me
Run "test" as a demo.

Option Explicit

Sub test()
Dim i As Long
Dim MyShape As Shape

Set MyShape = ActiveSheet.Shapes("MyPic")
Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Range("C17"), 0.3)
Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Range("H17"), 1.2)
Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Range("H1"), 3)
Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Range("H25"), 0.1)
Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Range("R55"), 0.5)
Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Range("R10"), 7)
Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Range("A10"), 30)

    For i = 1 To 6
    With ActiveWindow.VisibleRange
    Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Cells(1, .Columns.Count - 1), i * 0.4)
    Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Cells(.Rows.Count - 1, .Columns.Count - 1), i * 0.4)
    Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Cells(.Rows.Count - 1, 1), i * 0.4)
    Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Cells(1, 1), i * 0.4)
    End With
    Next i

Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Range("A10"), 0)
Call GlidePicBetweenCells(MyShape, MyShape.TopLeftCell, Range("A10"), -1)
End Sub

Sub GlidePicBetweenCells(MyShape As Shape, StartCell As Range, EndCell As Range, StepLength As Single)
'Erik Van Geit
'130105
'moves shape between two predefined cells at a certain speed
'didn't test if the "avoid rounding errors " lines are really necessary

'smaller shapes move faster
'building in a delay within the "for next" might be useful
'also a large StepLength makes the shape "jump"

Dim StartTop As Single
Dim StartLeft As Single
Dim EndTop As Single
Dim EndLeft As Single
Dim StepsCount As Single
Dim Distance As Single
Dim DistanceHor As Single
Dim DistanceVert As Single
Dim StepLengthHor As Single
Dim StepLengthVert As Single
Dim PositionTop As Single
Dim PositionLeft As Single
Dim OffsetVert As Single
Dim OffsetHor As Single
Dim i As Long

    If StepLength <= 0 Then
    MsgBox "The argument ""StepLength"" must be higher than 0." & vbNewLine & "It is now set as " & StepLength, vbCritical, "Error"
    Exit Sub
    End If

    With StartCell
    StartTop = .Top
    StartLeft = .Left
    End With
    
    With EndCell
    EndTop = .Top
    EndLeft = .Left
    End With

    
DistanceHor = EndLeft - StartLeft
DistanceVert = EndTop - StartTop
Distance = Sqr(DistanceHor ^ 2 + DistanceVert ^ 2)
StepsCount = Round(Distance / StepLength, 0)

        
    If DistanceVert <> 0 Then
    StepLengthHor = DistanceHor / StepsCount
    StepLengthVert = DistanceVert / StepsCount
    Else
    StepLengthHor = StepLength * -Sgn(StartCell.Column - EndCell.Column)
    StepLengthVert = 0
    End If

    With MyShape
    If .Height < StartCell.Height Then OffsetVert = (StartCell.Height - .Height) / 2
    If .Width < StartCell.Width Then OffsetHor = (StartCell.Width - .Width) / 2

    Application.ScreenUpdating = False
    PositionTop = StartTop + OffsetVert
    PositionLeft = StartLeft + OffsetHor
    .Top = PositionTop
    .Left = PositionLeft
    Application.ScreenUpdating = True

        'move MyShape
        For i = 1 To StepsCount
        '2 lines to avoid rounding errors
        PositionTop = PositionTop + StepLengthVert
        PositionLeft = PositionLeft + StepLengthHor
        .Top = PositionTop
        .Left = PositionLeft
        DoEvents
        Next i

    'avoid rounding errors
    .Top = EndTop + OffsetVert
    .Left = EndLeft + OffsetHor
    End With
End Sub

 

[erik.van.geit]

Forgot to add: at the end of "test" there are two lines which will cause custom error message. This is of course on purpose to show what happens if you put the "speed" at zero or "in reverse".

 

[Dixie77]

Hi Erik,

Thanks for all your help with this, it's much appreciated.

Still learning as I go

Regards

Rob