Excel Macros: Creating and managing drawing objects

'=======================================================================
'- CREATE & ARRANGE 4 TRAPEZOID SHAPES ON A WORKSHEET
'- (FROM DRAWING TOOLBAR - AUTOSHAPES - BASIC SHAPES)
'- Adds text from cells A1:A4
'- Brian Baulsom July 2007 - using Excel 2000
'=======================================================================
Dim TrapObj As Object           ' object to set properties
'- Trapezium Properties
'- to transfer values to the subroutine
Dim TrapTop As Double
Dim TrapLeft As Double
Dim TrapWidth As Double
Dim TrapHeight As Double
Dim TrapName As String
Dim TrapText As String
Dim TrapRotation As Integer
Dim TrapInterior As Integer
Dim TrapTextColor As Integer
'- Fill colours
Dim Navy As Integer
Dim Aqua As Integer
Dim Yellow As Integer
Dim Maroon As Integer
'-

'=======================================================================
'- MAIN ROUTINE
'=======================================================================
Sub ADD_SHAPES()
    Application.ScreenUpdating = False
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
    '==============================
    Navy = 18
    Aqua = 49
    Yellow = 13
    Maroon = 61
    '-----------------------------------------------------------------
    '- TRAP 1
    TrapLeft = 118.5
    TrapTop = 104.25
    TrapWidth = 200.25
    TrapHeight = TrapWidth / 4      ' to get 45 degree angle
    TrapName = "Trap1"
    TrapText = ActiveSheet.Range("A1")
    TrapRotation = 0
    TrapInterior = Navy
    TrapTextColor = 2               ' white text
    MakeTrapezoid           ' SUBROUTINE
    '-----------------------------------------------------------------
    '- TRAP 2
    TrapLeft = 42.75
    TrapTop = 179.25
    TrapWidth = 200.25
    TrapHeight = TrapWidth / 4       ' to get 45 degree angle
    TrapName = "Trap2"
    TrapText = ActiveSheet.Range("A2")
    TrapRotation = 270
    TrapInterior = Aqua
    TrapTextColor = xlAutomatic
    MakeTrapezoid           ' SUBROUTINE
    '-----------------------------------------------------------------
    '- TRAP 3
    TrapLeft = 118.5
    TrapTop = 254.25
    TrapWidth = 200.25
    TrapHeight = TrapWidth / 4       ' to get 45 degree angle
    TrapName = "Trap3"
    TrapText = ActiveSheet.Range("A3")
    TrapRotation = 180
    TrapInterior = Yellow
    TrapTextColor = xlAutomatic
    MakeTrapezoid           ' SUBROUTINE
    '-----------------------------------------------------------------
    '- TRAP 4
    TrapLeft = 194.25
    TrapTop = 179.25
    TrapWidth = 200.25
    TrapHeight = TrapWidth / 4       ' to get 45 degree angle
    TrapName = "Trap4"
    TrapText = ActiveSheet.Range("A4")
    TrapRotation = 90
    TrapInterior = Maroon
    TrapTextColor = 2                ' white text
    MakeTrapezoid           ' SUBROUTINE
    '-----------------------------------------------------------------
    ActiveSheet.Range("A1").Select
    Application.ScreenUpdating = True
    MsgBox ("Done")
End Sub
'========= END OF MAIN ROUTINE =======================================

'=====================================================================
'- SUBROUTINE TO MAKE THE TRAPEZOID
'=====================================================================
Private Sub MakeTrapezoid()
    ' Type,Left,Top,Width,Height
    Set TrapObj = ActiveSheet.Shapes.AddShape _
        (msoShapeTrapezoid, TrapLeft, TrapTop, TrapWidth, TrapHeight)
    With TrapObj
        .Name = TrapName
        .Fill.ForeColor.SchemeColor = TrapInterior
        .Rotation = TrapRotation
        .Placement = xlFreeFloating
        With .TextFrame
            .Characters.Text = TrapText
            .Characters.Font.Size = 10
            .Characters.Font.ColorIndex = TrapTextColor
            .HorizontalAlignment = xlHAlignCenter
            .VerticalAlignment = xlVAlignCenter
       End With
    End With
End Sub
'======================================================================

'======================================================================
'- RUN THIS AFTER MANUAL ARRANGEMENT TO SHOW SHAPE POSITIONS
'======================================================================
Sub SHOW_DETAILS()
    ActiveSheet.Range("E1:I1").Value = Array("NAME", "LEFT", "TOP", "WIDTH", "HEIGHT")
    R = 2
    For Each s In ActiveSheet.Shapes
        Cells(R, 5).Value = s.Name
        Cells(R, 6).Value = s.Left
        Cells(R, 7).Value = s.Top
        Cells(R, 8).Value = s.Width
        Cells(R, 9).Value = s.Height
        R = R + 1
    Next
End Sub
'============================================================