Disable 'Save As' dialog

[perhol]

In an account sheet i have made (with help from 'vbax - thankyou) a sub to create proper filename and save file with that name and in a folder depending on part of the name.
This is the code:

Sub GemSom()
Dim ws As Worksheet
Set ws = Sheets("Kasserapport")
If Test(ws) = False Then
With Sheets("Kasserapport")
ActiveWorkbook.SaveAs CheckMakePath("G:\" & _
Sheets("Kasserapport").Range("H4").Text & "-huset" & "\" & "Beboere" & "\" & _
Sheets("Kasserapport").Range("D2").Text & "\" & "Regnskab" & "\" & _
Format(Sheets("Kasserapport").Range("A4"), "yyyy")) & _
"Regnskab " & Format(Sheets("Kasserapport").Range("A4"), "mm-yyyy") & _
" " & Sheets("Kasserapport").Range("D2").Text & ".xls"
End With
Else
MsgBox ("Udfyld f?rst Beboernavn og Startdato.")
End If
End Sub

Function Test(ws As Worksheet) As Boolean
If ws.Range("A4") = "" Or ws.Range("A4") = "01.01.00" Or ws.Range("D2") = "" Or ws.Range("D2") = "V?lg Beboernavn" _
Then Test = True
End Function

Function CheckMakePath(ByVal vPath As String) As String
Dim PathSep As Long, oPS As Long
If Right(vPath, 1) <> "\" Then vPath = vPath & "\"
PathSep = InStr(3, vPath, "\") 'Position af drev-seperatoren i stien
If PathSep = 0 Then Exit Function 'Ugyldig sti
Do
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\") 'Position af folder
If PathSep = 0 Then Exit Do
If Len(Dir(Left(vPath, PathSep), vbDirectory)) = 0 Then Exit Do 'check stien
Loop
Do Until PathSep = 0
MkDir Left(vPath, PathSep)
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\")
Loop
CheckMakePath = vPath
End Function

To prevent users from saving with wrong name using 'Save' and 'Save As' from the File-menu i use Workbook_BeforeSave event to call the sub 'GemSom'. This method will still allow other open workbooks to be saved the normal way, while at the same time, prevent it in the account workbook.
Only problem with this is, that when my sub is done saving, the 'Save As' dialog opens.
How do i prevent this dialog from opening.

[Zack Barresse]

Hi there,

These two should do it for you (in the BeforeSave event)...


SaveAsUI = False
Cancel = True

HTH

[mikerickson]

I think a BeforeSave routine like this might work for you. Since file names can't be changed with Save, this routine only effects SaveAs.


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If SaveAsUI Then
Rem if SaveAs is in progress
Application.EnableEvents = False: Rem prevent GemSom from triggering cascading BeforeSave's
Call GemSom: Rem custom save routine
Cancel = True: Rem spike normal SaveAs
Application.EnableEvents = True
End If
End Sub

[perhol]

-> mikerickson

Your code did it. Thankyou.

Because the BeforeSave have to test 2 conditions the code now looks like this:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
With Sheets("Kasserapport")
If .Range("D2") = "" Or .Range("A4") = "" Then
Cancel = True
MsgBox (" Regnskabet gemmes ikke!" & vbCr & _
"Udfyld f?rst Beboernavn og Startdato.")
End If
End With
If SaveAsUI Then 'Hvis SaveAs er startet
Application.EnableEvents = False:
Call GemSom:
Cancel = True:
Application.EnableEvents = True
End If
End Sub

[mikerickson]

Glad I could help.