Zwischenspeicherung einer Datei
18.02.2020 13:45:30
STeve
Siehe ua. Code von Sepp v. 11.1.19.
Es wird die akt. Datei mit ..............z.B.:..Dateiname.xlsm.......im gleichen Ordner unter:
..Dateiname_1.xlsm........
...Dateiname_2.xlsm...
...Dateiname_3.xlsm...
fortlaufend aufsteigend abgespeichert..........
Wenn aber einer User/Bearbeiter der Datei aber z.B. die Zwischenspeicherung ....... _1 rauslöscht - - dann wird wieder unter _1 die letzte Version abgespeichert................dies soll aber nicht geschehen sondern die Nummerierung soll nur nach oben ausgeführt werden.
z.B.: folgende Sicherungen sind vorhanden:
...Dateiname_2.xlsm...
...Dateiname_3.xlsm...
..Dateiname_4.xlsm........
...Dateiname_5.xlsm...
...Dateiname_6.xlsm...
Es fehlt also die Nr. _1............dann soll die _7 als nächste Speicherung angelegt werden.
Hoffe ihr könnt mir helfen.
Besten Dank und mfg
STeve
Sub Zwischenspeichern() ''progr. von Sepp am 11.1.19 auf Herber
Dim strPath As String
Dim strFile As String
Dim strExt As String
Dim strNewFile As String
Dim varFile As Variant
strPath = ThisWorkbook.Path
varFile = Split(Split(ThisWorkbook.Name, ".")(0), "_")
strExt = Split(ThisWorkbook.Name, ".")(1)
If IsNumeric(varFile(UBound(varFile))) Then ReDim Preserve varFile(UBound(varFile) - 1)
strFile = strFile & Join(varFile, "_") & "($)." & strExt
strNewFile = NextFileIndexName(strPath, strFile, "_0", 1)
If Len(strNewFile) Then
' MsgBox "Die Datei '" & strNewFile & "' wird neu angelegt!"
ActiveWorkbook.SaveAs Filename:=strNewFile
Else
MsgBox "Eine Zwischenspeicherung der akt. Datei konnte leider nicht durchgeführt werden."
End If
End Sub
Private Function NextFileIndexName(ByVal FilePath As String, ByVal FileNamePattern As String, _
_
Optional ByVal IndexFormat As _
String = "-0", Optional ByVal StartIndex As Long = 0, Optional ByVal ShowNullIndex As Boolean _
_
= True) As String
'PARAMETERINFO:
'FilePath = Directory where the file is or should be located.
'FileNamePattern = Filename where '($)' marks the position of index-number!
'IndexFormat = The desired Format of the indexnumber.
'StartIndex = Lower bound of the indexnumber.
'ShowNullIndex = If true, the index '0' will be shown in the filename.
Dim varFile As Variant, strCheck As String, strIndex As String, strTemp As String, lngIndex _
_
As Long
Const PLACEHOLDER As String = "($)"
On Error GoTo ErrorHandler
If InStr(1, FileNamePattern, PLACEHOLDER) = 0 Then GoTo ErrorHandler
If Len(FileNamePattern) Len(Replace(FileNamePattern, PLACEHOLDER, "")) + Len(PLACEHOLDER) _
_
Then GoTo ErrorHandler
If Dir(FilePath, vbDirectory) = "" Then GoTo ErrorHandler
If Right(FilePath, 1) "\" Then FilePath = FilePath & "\"
varFile = Split(FileNamePattern, PLACEHOLDER)
lngIndex = StartIndex
Do
If lngIndex = 0 And ShowNullIndex Then
strIndex = Format(lngIndex, IndexFormat)
ElseIf lngIndex > 0 Then
strIndex = Format(lngIndex, IndexFormat)
End If
lngIndex = lngIndex + 1
strTemp = FilePath & varFile(0) & strIndex & varFile(1)
strCheck = Dir(strTemp, vbNormal)
Loop Until strCheck = ""
NextFileIndexName = strTemp
Exit Function
ErrorHandler:
NextFileIndexName = ""
End Function