Animate a traced object by using VBA

Question

What is the coding to animate a traced objects with the coordinates by using a command button? the coordinates are given, now just have to write the coding for the command button to animate the image

Answer 1

If I understand correctly, you want to move a shape (such as a text box, shape or button) from one place on the sheet to another and make it appear 'animated' instead of just jumping to the destination location?  If that is correct then this code should give you a starting point to play with.  You will need to edit the code to set the myShape object to the object to be moved.  You can play with the two Const values to get the animation appearance and speed that you like.

Sub MoveIt()

  'how many steps to use in the animation

  Const numberOfSteps = 20 ' higher the #, slower the move

  'how long to delay at each step to give the appearance

  'of animation. 0.1= 1/10 second  0.05 = 1/20 second

  Const delayTime = 0.05

  Dim myShape As Shape

  Dim topInc As Long

  Dim leftInc As Long

  Dim endTop As Long

  Dim endLeft As Long

  Dim moveLoop As Integer

  Dim tStart As Double

  'set reference to the object to be moved

  'in this case it was a simple rectangle

  'that was the only shape on the sheet

  Set myShape = ActiveSheet.Shapes(1)

  'move to top = 215, left=400

  'get the coordinates to move to

  'must be >= 0

  endTop = 215

  endLeft = 400

  'calculate how far to move at each step

  'of the animation

  topInc = (endTop - myShape.Top) / numberOfSteps

  leftInc = (endLeft - myShape.Left) / numberOfSteps

  For moveLoop = 1 To numberOfSteps

    myShape.Top = myShape.Top + topInc

    myShape.Left = myShape.Left + leftInc

    'need to delay for appearance of animation

    '0.1 = approx 1/10 second, 0.05 = approx 1/20 second

    tStart = Timer

    Do While Timer < tStart + delayTime

      DoEvents

    Loop

  Next

  Set myShape = Nothing

End Sub

Answer 2

Hi,

try and this.... 'Arrow'

[Edit..]

Sub Arrow_01()

Dim r1 As Variant

Set ws = ActiveSheet

For Each s In ActiveSheet.Shapes

If Not Intersect(s.TopLeftCell, Range("A1")) Is Nothing Then s.Delete

Next

Set r1 = ws.Shapes.AddLine(10, 10, 80, 10)

With r1.Line

.DashStyle = msoLineSolid

.ForeColor.RGB = RGB(0, 255, 255)

.Weight = 4.5

.BeginArrowheadStyle = msoArrowheadOval

.EndArrowheadStyle = msoArrowheadStealth

End With

Application.Wait Time + TimeValue("00:00:01")

For x = 1 To 12

Application.Wait Time + TimeValue("00:00:01")

With ws.Shapes(r1.Name)

.Left = 10 + 10 * x

.Top = 10 + 10 * x

.IncrementRotation 30

End With

Next

Application.Wait Time + TimeValue("00:00:01")

For x = 1 To 12

Application.Wait Time + TimeValue("00:00:01")

With ws.Shapes(r1.Name)

.Left = 130 - 10 * x

.Top = 130 - 10 * x

.IncrementRotation -30

End With

Next

End Sub

XXXXXXXXXXXXXX

Delete shape(s)

NOTE: Select the desired range and run this code

Sub Delete_Specific_Shapes()

For Each s In ActiveSheet.Shapes

If Not Intersect(s.TopLeftCell, Selection) Is Nothing Then Then s.Delete

Next

End Sub