Option Explicit
Function SaveSheet(ByVal Sheets2Save As Object, ByVal FileName2Save As String, _
ByVal FileFormat As XlFileFormat, ByVal OverWrite As Boolean) As String
Dim bChk As Boolean
Dim Folder2Save As String, sComm As String, Ext As String, ErrMsg As String
Dim fso As Object, oWsh As Object, wkb As Workbook
On Error GoTo ExitFunc
Set fso = CreateObject("Scripting.FileSystemObject")
bChk = fso.FileExists(FileName2Save)
If (bChk = False) Or OverWrite Then
Folder2Save = Mid(FileName2Save, 1, InStrRev(FileName2Save, "\") - 1)
If fso.FolderExists(Folder2Save) = False Then
Set oWsh = CreateObject("Wscript.Shell")
sComm = "MkDir " & """" & Folder2Save & """"
oWsh.Run "cmd /u /c " & sComm, 0, True
End If
If fso.FolderExists(Folder2Save) Then
Ext = fso.GetExtensionName(FileName2Save)
If Len(Ext) Then FileName2Save = Left(FileName2Save, Len(FileName2Save) - Len(Ext) - 1)
If (TypeName(Sheets2Save) = "Sheets") Or (TypeName(Sheets2Save) = "Worksheet") Then
Application.DisplayAlerts = False
Sheets2Save.Copy
Set wkb = ActiveWorkbook
With wkb
.SaveAs FileName2Save, FileFormat
SaveSheet = .FullName
.Close (True)
End With
Application.DisplayAlerts = True
End If
End If
End If
ExitFunc:
ErrMsg = Err.Description
If Err.Number = 1004 Then
If Not wkb Is Nothing Then
If UCase(wkb.Name) <> UCase(Sheets2Save.Parent.Name) Then wkb.Close (False)
End If
MsgBox ErrMsg
End If
Set fso = Nothing: Set oWsh = Nothing
End Function
