Zwei Makros: Bitte beurteilen & verwenden
Holger,
ich habe zwei Makro geschrieben, besser gesagt eine Prozedur und eine Funktion.
Die Prozedur (sie soll ins Ereignis Workbook Close) erstellt eine Kopie der Arbeitsmappe
mit Datum im Namen zu besseren Auffindbarkeit.
In dieser wird die Funktion aufgerufen, welche diese Datei automatisch zippt mit Passwort.
Ich wäre dankbar für eure Tipps/Kritiken und natürlich kann sich jeder bedienen,
der hier war gebrauchen kann.
Gruß
Holger
Option Explicit
Option Private Module
Const BDir = "Sicherungskopien"
Sub CreateBackUp()
Dim wbMaster As Workbook
Dim strBackUpPath As String, strBackUpFile As String, strSysInfo As String, _
strRARPath As String, strRARName As String
Dim blnError As Boolean
Set wbMaster = ThisWorkbook
ChDrive wbMaster.Path
ChDir wbMaster.Path
If IsDiskFolder(BDir) = False Then
MkDir BDir
End If
strRARName = GetWeekday & " " & Date
strBackUpFile = Left(wbMaster.Name, InStr(1, wbMaster.Name, ".") - 1) & _
" " & strRARName & _
Mid(wbMaster.Name, InStr(1, wbMaster.Name, "."))
strBackUpPath = wbMaster.Path & "\" & BDir & "\" & _
strBackUpFile
If IsDiskFolder(strBackUpPath) = True Then Kill strBackUpPath
ActiveWorkbook.SaveCopyAs Filename:=strBackUpPath
If CreateRAR(Chr(34) & strBackUpFile & Chr(34), "RAR", wbMaster.Path & "\" & BDir, Date & ". _
rar") = True Then
Kill strBackUpPath
Else
MsgBox "Fehler beim Zippen des folgenden Files " & Chr(10) & _
strBackUpPath & Chr(10) & _
", bitte prüfen!", vbCritical
End If
Set wbMaster = Nothing
End Sub
Private Function IsDiskFolder(ByVal fName As String) As Boolean 'liefert True _
zurück, wenn der Ordner existiert
If (Dir(fName, vbDirectory) "") Then
IsDiskFolder = True
Else
IsDiskFolder = False
End If
End Function
Private Function GetWeekday() As String
Dim bytWeekDay As Byte
bytWeekDay = Weekday(Date)
Select Case bytWeekDay
Case 1
GetWeekday = "Sonntag"
Case 2
GetWeekday = "Montag"
Case 3
GetWeekday = "Dienstag"
Case 4
GetWeekday = "Mittwoch"
Case 5
GetWeekday = "Donnerstag"
Case 6
GetWeekday = "Freitag"
Case 7
GetWeekday = "Samstag"
End Select
End Function
Public Function CreateRAR(ByVal FILE As String, ByVal RARMETHOD As String, _
ByVal DIRECTORY As String, Optional ByVal ARCHIV As String) As _
Boolean
Dim strSysInfo As String, strRARPath As String, strPassword As String, _
strCommandLine As String
strPassword = "Telecom"
strSysInfo = Replace(Mid(Application.OperatingSystem, 20, 5), " ", "")
Select Case Left(strSysInfo, 1)
Case 5
strRARPath = "C:\Programme\WinRAR\"
Case 6
strRARPath = "C:\Program Files\WinRAR\"
Case Else
CreateRAR = False
Exit Function
End Select
If (Dir(strRARPath, vbDirectory) = "") Then
CreateRAR = False
Exit Function
End If
ChDrive DIRECTORY
ChDir DIRECTORY
Select Case RARMETHOD
Case "RAR"
strRARPath = strRARPath & "WinRAR.exe"
strCommandLine = strRARPath & " " & _
"a -u -ibck -hp" & _
strPassword & " " & _
ARCHIV & " " & _
FILE
Case "UNRAR"
strRARPath = strRARPath & "UnRAR.exe"
strCommandLine = strRARPath & " " & _
"e -p" & _
strPassword & " " & _
FILE
End Select
Shell strCommandLine
CreateRAR = True
End Function