Attribute VB_Name = "OL_Backup"
Option Explicit

'© 2004 c't, Ralf Nebelo

Public Const APPNAME As String = "Outlook-Datensicherung"

'*****************************************************************
'Makros
'*****************************************************************

Public Sub OLBA_StartButtonAnlegen()
    Dim strCBName As String
    Dim objCB As CommandBar
    Dim objButton As CommandBarButton
    
    'Fehlerverfolgung ausschalten
    On Error Resume Next
    
    'Name der Befehlsleiste
    strCBName = "Makros"
    'Verweis auf Befehlsleiste holen
    Set objCB = ActiveExplorer.CommandBars(strCBName)
    'Wenn Befehlsleiste nicht existiert, dann...
    If objCB Is Nothing Then
        '... Befehlsleiste anlegen
        Set objCB = ActiveExplorer.CommandBars.Add(strCBName, msoBarTop)
    End If
    
    'Verweis auf Button holen
    Set objButton = objCB.FindControl(Tag:=APPNAME)
    'Wenn Button nicht existiert, dann...
    If objButton Is Nothing Then
        '... Button neu anlegen
        Set objButton = objCB.Controls.Add(Type:=msoControlButton)
        'Button konfigurieren
        With objButton
            'Tag-Wert zur Identifikation setzen
            .Tag = APPNAME
            'Nur Beschriftung
            .Style = msoButtonCaption
            'Gruppierung beginnen
            .BeginGroup = True
            'Beschriftung festlegen
            .Caption = APPNAME
            'Tooltip-Text festlegen
            .TooltipText = "Skript für die Sicherung aller Outlook-Daten generieren"
            'Mit Makro verknüpfen
            .OnAction = "OLBA_Sichern"
        End With
    End If
    
    'Befehlsleiste sichtbar machen
    objCB.Visible = True
End Sub

Public Sub OLBA_Sichern()
    Dim objDialogOCX As Object
    Dim strZielPfad As String
    Dim strSkriptName As String
    
    'Verweis auf ActiveX-Control Dialoge.ocx holen
    Set objDialogOCX = CreateObject("Dialoge.MyControl")
    
    'Sicherungsordner abfragen. Der zuletzt gewählte Ordner
    'ist als Vorgabe bereits markiert
    strZielPfad = objDialogOCX.GetFolder("Bitte wählen Sie den Sicherungsordner:", "Arbeitsplatz", GetSetting(APPNAME, "Einstellungen", "ZielPfad", ""), True, False, False)
    'Wenn Ordner gewählt, dann...
    If strZielPfad > "" Then
        '... Name des Sicherungsskripts festlegen
        strSkriptName = "OLBackup.vbs"
        
        'Wenn Skriptgenerierung erfolgreich, dann...
        If SkriptGenerieren(strSkriptName, strZielPfad) = True Then
            '... Meldung ausgeben
            MsgBox "Sicherungsskript erfolgreich generiert. Bitte beenden Sie Outlook und" & vbCr & "starten Sie das Skript " & strSkriptName & " auf Ihrem Desktop.", vbInformation, APPNAME
            'Pfad des Sicherungsordners in Registry speichern
            SaveSetting APPNAME, "Einstellungen", "ZielPfad", strZielPfad
        End If
    End If
End Sub

'*****************************************************************
'Allgemeine Prozeduren
'*****************************************************************

Private Function SkriptGenerieren(strSkriptName As String, strZielPfad As String) As Boolean
    Dim objWS As Object
    Dim objFSO As Object
    Dim strVBSFile As String
    Dim strPSTPfad As String
    Dim strOTMPfad As String
    
    'Fehlerverfolgung ausschalten
    On Error Resume Next
    
    'Verweis auf Scripting Host holen
    Set objWS = CreateObject("WScript.Shell")
    'Verweis auf FileSystemObject-Objekt holen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'Pfadnamen der Skriptdatei aus Desktop-Pfad und Dateinamen
    'zusammensetzen
    strVBSFile = objWS.SpecialFolders("Desktop") & "\" & strSkriptName
    'Wenn Skriptdatei bereits existiert, dann...
    If objFSO.FileExists(strVBSFile) = True Then
        '... Skriptdatei löschen
        Kill strVBSFile
    End If
    
    'Pfad des Outlook-Ordners ermitteln, der u.a. die PST-Datei enthält
    strPSTPfad = objWS.RegRead("HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Local AppData") & "\Microsoft\Outlook"
    'Pfad des Outlook-Ordners ermitteln, der die übrigen Outlook-Daten enthält
    strOTMPfad = objWS.RegRead("HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\AppData") & "\Microsoft\Outlook"
    
    'Neue Skriptdatei für die Textausgabe öffnen
    Open strVBSFile For Output As #1
    'Skriptzeilen hineinschreiben
    Print #1, "Set objWS = CreateObject(""WScript.Shell"")"
    Print #1, "strZielOrdner = " & Chr(34) & strZielPfad & Chr(34)
    Print #1, "strQuellOrdner = " & Chr(34) & strPSTPfad & Chr(34)
    Print #1, "intZaehler = OrdnerSichern(strQuellOrdner, strZielOrdner)"
    Print #1, "strQuellOrdner = " & Chr(34) & strOTMPfad & Chr(34)
    Print #1, "intZaehler = intZaehler + OrdnerSichern(strQuellOrdner, strZielOrdner)"
    Print #1, "MsgBox intZaehler & "" Dateien in "" & strZielOrdner & "" gesichert."", vbInformation, Wscript.ScriptName"
    Print #1, "objWS.Run ""Explorer.exe /e,"" & strZielOrdner"
    Print #1, "Function OrdnerSichern(strQuellOrdner, strZielOrdner)"
    Print #1, "  On Error Resume Next"
    Print #1, "  Set objFSO = CreateObject(""Scripting.FileSystemObject"")"
    Print #1, "  Set objQuellOrdner = objFSO.GetFolder(strQuellOrdner)"
    Print #1, "  Set objShell = CreateObject(""Shell.Application"")"
    Print #1, "  Set objZielOrdner = objShell.NameSpace(strZielOrdner)"
    Print #1, "  intCount = objFSO.GetFolder(strZielOrdner).Files.Count"
    Print #1, "  For Each objDatei In objQuellOrdner.Files"
    Print #1, "    objZielOrdner.CopyHere objDatei.Path, 8"
    Print #1, "  Next"
    Print #1, "  OrdnerSichern = objFSO.GetFolder(strZielOrdner).Files.Count - intCount"
    Print #1, "End Function"
    'Skriptdatei schließen
    Close #1
    
    'Erfolg oder Nichterfolg der Skriptgenerierung zurückmelden
    SkriptGenerieren = objFSO.FileExists(strVBSFile)
End Function

