perhol
05-16-2008, 04:21 PM
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.
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.