BeforeSave loops and workbook closes

[dhregan]

Hello -

I am attempting to save a "copy" of a workbook by forcing a set path and filename. The following code does two things that I would like to avoid. First, the "message" is displayed twice. Why is this occurring and how can I prevent it? Second, the workbook closes after the save completes, even if I only click on the save icon. I need the workbook to stay open unless the red "x" is pressed. Here is the code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)


Const Function_Area = "Benefits"


Dim Full_Filename As String
Dim Temp_Filename_Prefix As String
Dim Temp_Filename_Suffix As String
Dim Temp_Path As String


Dim Error_Check As Boolean


Dim End_Msg As Variant


Dim Temp_Object As Object


    Set Temp_Object = CreateObject("WScript.Shell")
    
    With Temp_Object
        Temp_Path = .SpecialFolders("Desktop") & "\"
    End With
    
    If Range("REVIEW_TYPE").Value = "Prototype Review" Then
        Temp_Filename_Prefix = Range("CUSTOMER_NAME").Value & Function_Area & "_PROTO_"
    End If
    If Range("REVIEW_TYPE").Value = "Final Review" Then
        Temp_Filename_Prefix = Range("CUSTOMER_NAME").Value & Function_Area & "_FINAL_"
    End If
    If Range("REVIEW_TYPE").Value = "Compliance Review" Then
        Temp_Filename_Prefix = Range("CUSTOMER_NAME").Value & Function_Area & "_COMPLIANCE_"
    End If
    
    Temp_Filename_Suffix = Format(Date, "yyyymmdd")
    Temp_Filename_Suffix = Temp_Filename_Suffix & "C"
    
    Full_Filename = Temp_Path & Temp_Filename_Prefix & Temp_Filename_Suffix


    End_Msg = "This file has been saved to your DESKTOP as " & Chr(13) & Chr(10) & _
        Full_Filename
    End_Msg = MsgBox(End_Msg, vbInformation, "FILE SAVED")


' Save file to Desktop


    ActiveWorkbook.SaveAs Filename:=Full_Filename, FileFormat:=52
    ThisWorkbook.Saved = True
    
End Sub