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

Thank you for any guidance you can provide.

[SamT]

Turn off Application Events before SaveAs
or
Use SaveCopyAs

My own Personal.xls procedures

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not Me.Saved Then Me.Save
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUi As Boolean, Cancel As Boolean)
Me.SaveCopyAs ("E:\COMPUTING\VBA\MyPersonal\" & CDbl(Now) & "- Personal.xls")
End Sub

[Paul_Hossler]

Simplified a bit, and added .EnableEvents = False to avoid the BeforeSave event handler calling itself




Option Explicit

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

Temp_Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"

Select Case Range("REVIEW_TYPE").Value
Case "Prototype Review"
Temp_Filename_Prefix = Range("CUSTOMER_NAME").Value & Function_Area & "_PROTO_"
Case "Final Review"
Temp_Filename_Prefix = Range("CUSTOMER_NAME").Value & Function_Area & "_FINAL_"
Case "Compliance Review"
Temp_Filename_Prefix = Range("CUSTOMER_NAME").Value & Function_Area & "_COMPLIANCE_"
End Select

Temp_Filename_Suffix = Format(Date, "yyyymmdd") & "C"

Full_Filename = Temp_Path & Temp_Filename_Prefix & Temp_Filename_Suffix

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

' Save file to Desktop
Application.EnableEvents = False ' <<<<<<<<<<<<<<<<<<<<<
ThisWorkbook.SaveAs Filename:=Full_Filename, FileFormat:=52
Application.EnableEvents = True

ThisWorkbook.Saved = True

End Sub