How about something like:
Option Explicit
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(szPath)
If lReturn = 0 Then Err.Raise vbObjectError + 1, "Error setting path."
End Sub
Sub testme()
Dim myNewFolder As String
Dim CurFolder As String
Dim UserFileName As Variant
Dim UserFolder As String
Dim TestStr As String
Dim resp As Long
If ActiveWorkbook.Path = "" Then
'keep going, it was based on a template (*.xlt) and hasn't been saved
Else
'get out, it's already been saved
Exit Sub
End If
myNewFolder = "\\C:\my documents\excel"
CurFolder = CurDir
On Error Resume Next
ChDirNet myNewFolder
If Err.Number <> 0 Then
'what should happen
MsgBox "Design error--Folder not found" & vbLf & _
"Contact Vibeke right away, please."
Err.Clear
Exit Sub
End If
On Error GoTo 0
UserFileName = Application.GetSaveAsFilename _
(InitialFileName:="Please Stay in this folder!", _
filefilter:="Excel Files, *.xls")
ChDrive CurFolder
ChDir CurFolder
If UserFileName = False Then
'user hit cancel
Exit Sub
End If
UserFolder = Left(UserFileName, InStrRev(stringcheck:=UserFileName, _
stringmatch:="\", Start:=-1, compare:=vbTextCompare) - 1)
If LCase(UserFolder) = LCase(myNewFolder) Then
'ok
Else
Beep
MsgBox "File NOT Saved!" & vbLf & vbLf _
& "Please choose a filename in: " & vbLf & myNewFolder
Exit Sub
End If
TestStr = ""
On Error Resume Next
TestStr = Dir(UserFileName)
On Error GoTo 0
If TestStr = "" Then
'file doesn't exist
'don't prompt about overwriting
Else
'give them a choice
resp = MsgBox(Prompt:="Overwrite existing file?", Buttons:=vbYesNo)
If resp = vbNo Then
MsgBox "File not saved"
Exit Sub
End If
End If
Application.DisplayAlerts = False 'stop overwrite prompt
Application.EnableEvents = False 'get by that workbook_beforesave event
On Error Resume Next 'just in case
ActiveWorkbook.SaveAs Filename:=UserFileName, _
FileFormat:=xlWorkbookNormal
If Err.Number <> 0 Then
MsgBox "File not saved!" & vbLf & _
Err.Number & vbLf & Err.Description
Err.Clear
Else
MsgBox "Saved to:" & vbLf & UserFileName
End If
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
This actually prompts the user to see if they want to overwrite the existing
file. It may be easier to allow the users to do this than explain why they
can't update an existing file.
But if you really don't want them to have this ability, change this section:
If TestStr = "" Then
'file doesn't exist
'don't prompt about overwriting
Else
'give them a choice
resp = MsgBox(Prompt:="Overwrite existing file?", Buttons:=vbYesNo)
If resp = vbNo Then
MsgBox "File not saved"
Exit Sub
End If
End If
to
If TestStr = "" Then
'file doesn't exist
'don't prompt about overwriting
Else
Msgbox "That name already exists!"
exit sub
End if
=======
And to try to stop the users from hitting the File|SaveAs dialog, put this in
the ThisWorkbook module:
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = True
MsgBox "Please use button to save this file"
End Sub
Be aware that if the user opens the workbook with macros disabled, then all this
fails. And if they disable events, it'll fail, too.