Option Explicit

Const xlMaximized             = &HFFFFEFD7

' Some of Enum MsoAutoShapeType
Const msoShapeRectangle       =  1
Const msoShapeDiamond         =  4

' Some Shape styles
Const msoShadow14             = 14
Const msoThreeD1              =  1
Const msoLineSolid            =  1
Const msoLineRoundDot         =  3
Const msoLineSingle           =  1
Const msoTrue                 = &HFFFFFFFF
Const msoGradientDiagonalDown =  4

' Some of Enum MsoPresetGradientType
Const msoGradientRainbow      = 16
Const msoGradientRainbowII    = 17

' Some of Enum MsoPresetExtrusionDirection
Const msoExtrusionBottomRight =  1
Const msoExtrusionBottom      =  2
Const msoExtrusionBottomLeft  =  3
Const msoExtrusionRight       =  4
Const msoExtrusionNone        =  5
Const msoExtrusionLeft        =  6
Const msoExtrusionTopRight    =  7
Const msoExtrusionTop         =  8
Const msoExtrusionTopLeft     =  9

' Some of Enum XlMousePointer
Const xlDefault               = &HFFFFEFD1
Const xlWait                  =  2


Dim objExcel
Dim objCommandBar
Dim dictCommandBars
Dim i

Dim sngStartCoord
Dim sngFlySize
Dim sngFigureSize

Dim sngStep
Dim sngSqrt2
Dim intExtrDirectionSquare
Dim intExtrDirectionRhombus

Dim objShapeSquare
Dim objShapeRhombus


Set objExcel        = WScript.CreateObject("Excel.Application")
Set dictCommandBars = WScript.CreateObject("Scripting.Dictionary")

With objExcel
    .Visible           = True
    .UserControl       = True
    
    .Cursor            = xlWait
    .Interactive       = False
    .ScreenUpdating    = False
    
    .WindowState       = xlMaximized
    
    .DisplayFormulaBar = False
    .DisplayStatusBar  = False
    
    .SheetsInNewWorkbook = 1
    
    For Each objCommandBar In .CommandBars
        If objCommandBar.Visible Then
            dictCommandBars.Add objCommandBar.Name, objCommandBar
            objCommandBar.Enabled = False
        End If
    Next
    
    With .Workbooks.Add
        With .ActiveSheet
            With .Application.ActiveWindow
                .DisplayGridlines           = False
                .DisplayHeadings            = False
                .DisplayOutline             = False
                .DisplayHorizontalScrollBar = False
                .DisplayVerticalScrollBar   = False
                .DisplayWorkbookTabs        = False
            End With
            
            sngStartCoord = 100
            sngFlySize    = 360
            sngFigureSize =  50
            
            With .Shapes.AddShape(msoShapeRectangle, sngStartCoord + sngFigureSize / 2, sngStartCoord + sngFigureSize / 2, sngFlySize, sngFlySize)
                With .Line
                    .Weight                = 0.25
                    .DashStyle             = msoLineSolid
                    .Style                 = msoLineSingle
                    .Transparency          = 0
                    .ForeColor.SchemeColor = 24
                    .Visible               = msoTrue
                End With
            End With
            
            With .Shapes.AddShape(msoShapeDiamond, sngStartCoord + sngFigureSize / 2, sngStartCoord + sngFigureSize / 2, sngFlySize, sngFlySize)
                With .Line
                    .Weight                = 0.25
                    .DashStyle             = msoLineSolid
                    .Style                 = msoLineSingle
                    .Transparency          = 0
                    .ForeColor.SchemeColor = 41
                    .Visible               = msoTrue
                End With
            End With
            
            intExtrDirectionSquare  = msoExtrusionBottomRight
            intExtrDirectionRhombus = msoExtrusionRight
            
            Set objShapeSquare = .Shapes.AddShape(msoShapeRectangle, sngStartCoord, sngStartCoord, sngFigureSize, sngFigureSize)
            SetShape objShapeSquare, 1, intExtrDirectionSquare
            
            Set objShapeRhombus = .Shapes.AddShape(msoShapeRectangle, sngStartCoord, sngStartCoord + sngFlySize / 2, sngFigureSize, sngFigureSize)
            SetShape objShapeRhombus, 2, intExtrDirectionRhombus
            objShapeRhombus.IncrementRotation 45
            
            .Application.ScreenUpdating = True
            WScript.Sleep 1000
            
            sngStep  = 3
            sngSqrt2 = Sqr(sngStep^2 + sngStep^2) / sngStep
            
            For i = 1 To sngFlySize Step sngStep
                If i >= sngFlySize / 3 * 2 Then
                    intExtrDirectionSquare  = msoExtrusionBottomLeft
                    intExtrDirectionRhombus = msoExtrusionTop
                ElseIf i >= sngFlySize / 3 Then
                    intExtrDirectionSquare  = msoExtrusionBottom
                    intExtrDirectionRhombus = msoExtrusionTopRight
                End If
                
                MoveShape objShapeSquare,   sngStep,          0, -sngStep, intExtrDirectionSquare
                MoveShape objShapeRhombus,  sngSqrt2,  sngSqrt2,  sngStep, intExtrDirectionRhombus
            Next
            
            For i = 1 To sngFlySize Step sngStep
                If i >= sngFlySize / 3 * 2 Then
                    intExtrDirectionSquare  = msoExtrusionTopLeft
                    intExtrDirectionRhombus = msoExtrusionLeft
                ElseIf i >= sngFlySize / 3 Then
                    intExtrDirectionSquare  = msoExtrusionLeft
                    intExtrDirectionRhombus = msoExtrusionTopLeft
                End If
                
                MoveShape objShapeSquare,          0,  sngStep,  -sngStep, intExtrDirectionSquare
                MoveShape objShapeRhombus,  sngSqrt2, -sngSqrt2,  sngStep, intExtrDirectionRhombus
            Next
            
            For i = 1 To sngFlySize Step sngStep
                If i >= sngFlySize / 3 * 2 Then
                    intExtrDirectionSquare  = msoExtrusionTopRight
                    intExtrDirectionRhombus = msoExtrusionBottom
                ElseIf i >= sngFlySize / 3 Then
                    intExtrDirectionSquare  = msoExtrusionTop
                    intExtrDirectionRhombus = msoExtrusionBottomLeft
                End If
                
                MoveShape objShapeSquare,  -sngStep,          0, -sngStep, intExtrDirectionSquare
                MoveShape objShapeRhombus, -sngSqrt2, -sngSqrt2,  sngStep, intExtrDirectionRhombus
            Next
            
            For i = 1 To sngFlySize Step sngStep
                If i >= sngFlySize / 3 * 2 Then
                    intExtrDirectionSquare  = msoExtrusionBottomRight
                    intExtrDirectionRhombus = msoExtrusionRight
                ElseIf i >= sngFlySize / 3 Then
                    intExtrDirectionSquare  = msoExtrusionRight
                    intExtrDirectionRhombus = msoExtrusionBottomRight
                End If
                
                MoveShape objShapeSquare,          0, -sngStep,  -sngStep, intExtrDirectionSquare
                MoveShape objShapeRhombus, -sngSqrt2,  sngSqrt2,  sngStep, intExtrDirectionRhombus
            Next
            
            WScript.Sleep 1000
            
            With .Application.ActiveWindow
                .DisplayGridlines           = True
                .DisplayHeadings            = True
                .DisplayOutline             = True
                .DisplayHorizontalScrollBar = True
                .DisplayVerticalScrollBar   = True
                .DisplayWorkbookTabs        = True
            End With
        End With
        
        .Saved = True
    End With
    
    For Each objCommandBar In dictCommandBars.Items
        objCommandBar.Enabled = True
    Next
    
    .Interactive       = True
    .Cursor            = xlDefault
    
    .DisplayFormulaBar = True
    .DisplayStatusBar  = True
End With

Set dictCommandBars = Nothing
Set objExcel        = Nothing

WScript.Quit 0
'=============================================================================

'=============================================================================
Sub MoveShape(objShape, sngIncLeft, sngIncTop, sngIncRotate, intExtrDirection)
    With objShape
        .IncrementLeft                sngIncLeft
        .IncrementTop                 sngIncTop
        .IncrementRotation            sngIncRotate
        .ThreeD.SetExtrusionDirection intExtrDirection
    End With
End Sub
'=============================================================================

'=============================================================================
Sub SetShape(objShape, intType, intExtrDirection)
    With objShape
        With .Line
            .Weight                = 0.25
            .DashStyle             = msoLineRoundDot
            .Style                 = msoLineSingle
            .Transparency          = 0
            .ForeColor.SchemeColor = 24
            .BackColor.RGB         = RGB(255, 255, 255)
            .Visible               = msoTrue
        End With
        
        With .Fill
            .Transparency          = 0
            
            Select Case intType
                Case 1
                    .ForeColor.RGB  = RGB(255, 51, 153)
                    .BackColor.RGB  = RGB(51, 102, 255)
                    .PresetGradient   msoGradientDiagonalDown, 2, msoGradientRainbowII
                Case 2
                    .ForeColor.RGB  = RGB(166, 3, 171)
                    .BackColor.RGB  = RGB(166, 3, 171)
                    .PresetGradient   msoGradientDiagonalDown, 1, msoGradientRainbow
                Case Else
                    ' Nothing to do
            End Select
            
            .Visible                = msoTrue
        End With
        
        With .ThreeD
            .ExtrusionColor.RGB     = RGB(204, 236, 255)
            .SetThreeDFormat          msoThreeD1
            .SetExtrusionDirection    intExtrDirection
            .Perspective            = True
            .Depth                  = 72
            .Visible                = msoTrue
        End With
    End With
End Sub
'=============================================================================

Sub newFigure()
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 200, 200, 50, 50).Select
    Selection.Name = "fig"
End Sub

Sub Run1()
    ActiveSheet.Shapes("fig").Select
    x = 0.75
    y = 0
    For k = 1 To 1600
        Selection.ShapeRange.IncrementLeft x
        Selection.ShapeRange.IncrementTop y
        Application.Wait (2)
        If k = 400 Then
            x = 0
            y = 0.75
        End If
        If k = 800 Then
            x = -0.75
            y = 0
        End If
        If k = 1200 Then
            x = 0
            y = -0.75
        End If
    Next k

End Sub

Sub Run2()
    ActiveSheet.Shapes("fig").Select
    x = 1
    y = 0.75
    For k = 1 To 800
        Selection.ShapeRange.IncrementLeft x
        Selection.ShapeRange.IncrementTop y
        Application.Wait (2)
        If k = 200 Then
            x = -1
        End If
        If k = 400 Then
            y = -0.75
        End If
        If k = 600 Then
            x = 1
        End If
    Next k
End Sub