The annoying in-the-stream ads

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub bleeding_nose()
'Erik Van Geit
'061107
Dim AWVRH As Integer
Dim AWVRW As Integer

Dim Sh As Shape
Dim TP As Double
Dim LP As Double
Dim ShH As Integer
Dim ShW As Integer
Dim ShClear As Shape

Dim WB As Workbook
Dim NoHarm As Boolean

Dim i As Integer

'if NoHarm is True then pressing escape will "undo" the macro
'if NoHarm is False you should stay in the neighbourhood ! :-)
NoHarm = True

    If NoHarm Then
    Application.ScreenUpdating = False
    ActiveSheet.Copy
    Set WB = ActiveWorkbook
    Application.ScreenUpdating = True
    Else
    'if any problems, you can find this file in same directory
    Set WB = ActiveWorkbook
    WB.SaveCopyAs Left(WB.FullName, Len(WB.FullName) - 4) & " no bled.xls"
    End If

Application.EnableCancelKey = xlErrorHandler
On Error GoTo StopBleeding

AWVRH = ActiveWindow.VisibleRange.Height * 0.95
AWVRW = ActiveWindow.VisibleRange.Width * 0.95

    Do
    Randomize Timer
    LP = Rnd * AWVRW + AWVRW * 0.025
    TP = Rnd * AWVRH + AWVRH * 0.025
    ShH = 4 * Rnd + 5
    ShW = 4 * Rnd + 5
    
        With WB.ActiveSheet.Shapes
            Select Case Rnd
            Case 0 To 0.6
            Set Sh = .AddShape(msoShapeExplosion1, LP, TP, ShW, ShH)
            Case 0.6 To 0.8
            Set Sh = .AddShape(msoShapeExplosion2, LP, TP, ShW, ShH)
            Case Else
            Set Sh = .AddShape(msoShapeSun, LP, TP, ShW, ShH)
            End Select
        End With
        
        With Sh
        .Fill.ForeColor.SchemeColor = 10
        .Fill.Transparency = Rnd * 0.8
        .Line.Visible = msoFalse
        If NoHarm = False Then .OnAction = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & ".xls!oh"
        End With
    
        For i = 1 To Int(Rnd * 10)
        Sleep CLng(Rnd * 99)
        DoEvents
        Next i

        For Each ShClear In ActiveSheet.Shapes
        If Not Intersect(Selection, ShClear.TopLeftCell) Is Nothing Then ShClear.Delete
        Next ShClear
    Loop

StopBleeding:
Err.Clear
Application.EnableCancelKey = xlDisabled
    If NoHarm Then
    WB.Close False
    Else
    'automatisation error if user closed WB "while bleeding"
    'same error checking if WB is still open
    'On Error Resume Next didn't work
    'not a big issue anyway :-)
        With WB.ActiveSheet.Buttons.Add(25, 25, 200, 80)
        .OnAction = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & ".xls!oh"
        .Characters.Text = "A fatal problem occured: " & vbLf & "Your system has solved this only partially. Please click the shapes and this button to remove them."
        End With
    End If

End Sub

Sub oh()
ActiveSheet.Shapes(Application.Caller).Delete
End Sub

Private Sub Workbook_Open()
'set the delay to run the code
Application.OnTime Now + TimeValue("00:03:00"), "bleeding_nose"
End Sub