Page 1 of 3 123 LastLast
Results 1 to 10 of 22

Animate Pic

This is a discussion on Animate Pic within the Excel Questions forums, part of the Question Forums category; Hi All, I've been asked to devise a basic snakes and ladders game for a bit of fun in the ...

  1. #1
    Board Regular
    Join Date
    Nov 2011
    Location
    Liverpool (England)
    Posts
    50

    Question Animate Pic

    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

  2. #2
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,765

    Default Re: Animate Pic

    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

  3. #3
    Board Regular
    Join Date
    Nov 2011
    Location
    Liverpool (England)
    Posts
    50

    Default Re: Animate Pic

    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

  4. #4
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,765

    Default Re: Animate Pic

    Create a shape, whatever you want.
    Name it MyPic
    Then try this code
    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

  5. #5
    Board Regular
    Join Date
    Nov 2011
    Location
    Liverpool (England)
    Posts
    50

    Default Re: Animate Pic

    Hi Erik,

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

    Thanks again,

    Rob

  6. #6
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,765

    Default Re: Animate Pic

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

  7. #7
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,765

    Default Re: Animate Pic

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

  8. #8
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,765

    Default Re: Animate Pic

    Couldn't forget this game
    This seems quite satisfactory to me
    Run "test" as a demo.
    Code:
    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
    Code:
    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
    Last edited by erik.van.geit; Mar 5th, 2013 at 02:13 PM.

  9. #9
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,765

    Default Re: Animate Pic

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

  10. #10
    Board Regular
    Join Date
    Nov 2011
    Location
    Liverpool (England)
    Posts
    50

    Default Re: Animate Pic

    Hi Erik,

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

    Still learning as I go

    Regards

    Rob

Page 1 of 3 123 LastLast

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  


DMCA.com