Activity Timer to count down..then save and close workbook

Private Sub Workbook_Open()
' Macro recorded 7/12/2002 by Justin
Worksheets("Table of Contents").Activate
Select Case Application.CanPlaySounds
    Case True
        sndPlaySound "C:\Windows\Media\Windows XP Startup.wav", 0
End Select
MsgBox ("For Support Contact: Justin" & vbNewLine & "Email: yada@yada.com" & vbNewLine & " " & vbNewLine & "**UPDATED INFORMATION (Oct 13, 2008):" & vbNewLine & "1. Table of Contents added and will prompt you if you dont have a worksheet created for the week." & vbNewLine & "2. Sound associated with Startup and Shutdown of the workbook." & vbNewLine & "3. Sound associated if current Work Week isn't created." & vbNewLine & "     It will then prompt you with the steps to creating a new Work Week." & vbNewLine & "4. Added option to send part of the work week or the entire workbook."), vbExclamation, "NetVersant - Northern California"
Range("A1").Select
Selection.ClearContents
Dim current_wk As Date: current_wk = DateAdd("d", 7 - Weekday(Date, vbMonday), Date)
Dim dummy As Variant
'check timesheet exists
On Error GoTo MissingSheet:
dummy = Sheets(Format(current_wk, "MMM DD, YYYY")).Cells(1, 1)
Call Hide_Worksheets_Reset
Worksheets("Table of Contents").Activate
Exit Sub
MissingSheet:
Select Case Application.CanPlaySounds
    Case True
        sndPlaySound "C:\Windows\Media\Notify.wav", 0
End Select
MsgBox "From the Table of Contents" & vbNewLine & "Please Create a Timesheet for Week Ending: " & Format(current_wk, "MMM DD, YYYY") & vbNewLine & " " & vbNewLine & "Select Option 1 and Create a New Timesheet first." & vbNewLine & "then once you are on the Blank Worksheet" & vbNewLine & "From the Pull down select this comming Sunday - Example: " & Format(current_wk, "MMM DD, YYYY") & vbNewLine & "then click 'Create New Timesheet'" & vbNewLine & "You will have a new Worksheet Labeled: " & Format(current_wk, "MMM DD, YYYY") & vbNewLine & "Enter your Time there. " & vbNewLine & "Save and Close or Email as you see fit.", vbExclamation, "Create a New Timesheet..."
Exit Sub
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Select Case Application.CanPlaySounds
    Case True
        sndPlaySound "C:\Windows\Media\Windows XP Shutdown.wav", 0
End Select
End Sub