Cinema
04-16-2019, 02:58 AM
Hi, my Code gives an error for the variable str_FileName in the line I have marked with "ERROR". If I replace this variable with a hard coded string like "String" then the code runs error-free.
Public Sub fkt_Copy()
Dim str_Path_Dest As String
Dim str_FileName As String
Dim str_DestPathName As String
Dim fnPos As Integer
Dim foFS As FileSystemObject
Dim bFileExists, bFileOpen As Boolean
Dim xApp As Excel.Application
Dim xWbk As Workbook
Dim ws As Worksheet
Dim fldr As FileDialog
Dim sItem As String
bFileExists = False
bFileOpen = False
On Error GoTo Err
Dim objShell
Dim strFileName As String
Dim strFilePath As String
Dim objFile As Object
Set objShell = CreateObject("Shell.Application")
Set objFile = objShell.BrowseForFolder(0, "Choose a folder:", &H1, 17)
If objFile Is Nothing Then Exit Sub
str_Path_Dest = objFile.Self.Path
Application.DisplayAlerts = False
str_FileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
str_DestPathName = str_Path_Dest & "\" & str_FileName & "_output" & ".xlsm"
'Prüfen, ob Workbook offen ist
If Dir(str_DestPathName) <> "" Then
bFileExists = True
If Not IsFileOpen(str_DestPathName) Then
bFileOpen = False
End If
End If
If Not bFileOpen Or Not bFileExists Then
'kopieren falls Clone nicht offen ist oder noch nicht existiert
Set foFS = New Scripting.FileSystemObject
If Left(ThisWorkbook.FullName, 3) Like "*:\" Then
Call foFS.CopyFile(ThisWorkbook.FullName, str_DestPathName, True)
Else
ActiveWorkbook.SaveCopyAs Filename:=str_DestPathName
End If
Set xApp = New Excel.Application
xApp.DisplayAlerts = False
xApp.EnableEvents = False
Set xWbk = xApp.Workbooks.Open(str_DestPathName, ReadOnly:=True)
For Each ws In xWbk.Worksheets
ws.Unprotect
If ws.FilterMode Then
ws.ShowAllData
End If
ws.UsedRange.Copy
ws.UsedRange.PasteSpecial xlPasteValues
Next ws
'Speichern des Clones als xlsx-File und schließen des Workbooks
xWbk.SaveAs str_Path_Dest & "\" & str_FileName & "_output", xlOpenXMLWorkbook <------- ERROR
xWbk.Protect
xWbk.Close
xApp.EnableEvents = True
xApp.DisplayAlerts = True
xApp.Quit
'löschen der als xlsm kopierten Clone-Datei
Kill str_DestPathName
MsgBox "Kopie gespeichert"
Else
MsgBox "Datei kann nicht kopiert werden. Zieldatei geöffnet"
End If
Exit Sub
Err:
MsgBox "Fehler bei Datei kopieren. " & Err.Description
'schließen des Workbooks bei Fehlern
If Not (xWbk Is Nothing) Then
xWbk.Close False
End If
If Not (xApp Is Nothing) Then
xApp.EnableEvents = True
xApp.DisplayAlerts = True
xApp.Quit
End If
Exit Sub
Application.DisplayAlerts = True
End Sub
Public Sub fkt_Copy()
Dim str_Path_Dest As String
Dim str_FileName As String
Dim str_DestPathName As String
Dim fnPos As Integer
Dim foFS As FileSystemObject
Dim bFileExists, bFileOpen As Boolean
Dim xApp As Excel.Application
Dim xWbk As Workbook
Dim ws As Worksheet
Dim fldr As FileDialog
Dim sItem As String
bFileExists = False
bFileOpen = False
On Error GoTo Err
Dim objShell
Dim strFileName As String
Dim strFilePath As String
Dim objFile As Object
Set objShell = CreateObject("Shell.Application")
Set objFile = objShell.BrowseForFolder(0, "Choose a folder:", &H1, 17)
If objFile Is Nothing Then Exit Sub
str_Path_Dest = objFile.Self.Path
Application.DisplayAlerts = False
str_FileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
str_DestPathName = str_Path_Dest & "\" & str_FileName & "_output" & ".xlsm"
'Prüfen, ob Workbook offen ist
If Dir(str_DestPathName) <> "" Then
bFileExists = True
If Not IsFileOpen(str_DestPathName) Then
bFileOpen = False
End If
End If
If Not bFileOpen Or Not bFileExists Then
'kopieren falls Clone nicht offen ist oder noch nicht existiert
Set foFS = New Scripting.FileSystemObject
If Left(ThisWorkbook.FullName, 3) Like "*:\" Then
Call foFS.CopyFile(ThisWorkbook.FullName, str_DestPathName, True)
Else
ActiveWorkbook.SaveCopyAs Filename:=str_DestPathName
End If
Set xApp = New Excel.Application
xApp.DisplayAlerts = False
xApp.EnableEvents = False
Set xWbk = xApp.Workbooks.Open(str_DestPathName, ReadOnly:=True)
For Each ws In xWbk.Worksheets
ws.Unprotect
If ws.FilterMode Then
ws.ShowAllData
End If
ws.UsedRange.Copy
ws.UsedRange.PasteSpecial xlPasteValues
Next ws
'Speichern des Clones als xlsx-File und schließen des Workbooks
xWbk.SaveAs str_Path_Dest & "\" & str_FileName & "_output", xlOpenXMLWorkbook <------- ERROR
xWbk.Protect
xWbk.Close
xApp.EnableEvents = True
xApp.DisplayAlerts = True
xApp.Quit
'löschen der als xlsm kopierten Clone-Datei
Kill str_DestPathName
MsgBox "Kopie gespeichert"
Else
MsgBox "Datei kann nicht kopiert werden. Zieldatei geöffnet"
End If
Exit Sub
Err:
MsgBox "Fehler bei Datei kopieren. " & Err.Description
'schließen des Workbooks bei Fehlern
If Not (xWbk Is Nothing) Then
xWbk.Close False
End If
If Not (xApp Is Nothing) Then
xApp.EnableEvents = True
xApp.DisplayAlerts = True
xApp.Quit
End If
Exit Sub
Application.DisplayAlerts = True
End Sub