Attribute VB_Name = "OL_Ansichten"
Option Explicit

'© 2004 c't, Ralf Nebelo
'Benötigt ActiveX-Control Dialoge.ocx

Public Const APPNAME As String = "Ordneransichten verwalten"

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

Public Sub OLAN_StartButtonsAnlegen()
    Dim strCBName As String
    Dim objCB As CommandBar
    Dim strButtonCaption As String
    Dim objButton As CommandBarButton
    Dim intPos As Integer
    
    '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
    
    'Button-Beschriftung angeben
    strButtonCaption = "Ansicht speichern"
    'Verweis auf Button holen
    Set objButton = objCB.FindControl(Tag:=strButtonCaption)
    '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 = strButtonCaption
            'Nur Beschriftung
            .Style = msoButtonCaption
            'Gruppierung beginnen
            .BeginGroup = True
            'Beschriftung festlegen
            .Caption = strButtonCaption
            'Tooltip-Text festlegen
            .TooltipText = "Aktuelle Ansicht in XML-Datei speichern"
            'Mit Makro verknüpfen
            .OnAction = "OLAN_AnsichtSpeichern"
        End With
    End If
    
    'Button-Beschriftung angeben
    strButtonCaption = "Ansicht laden"
    'Verweis auf Button holen
    Set objButton = objCB.FindControl(Tag:=strButtonCaption)
    '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 = strButtonCaption
            'Nur Beschriftung
            .Style = msoButtonCaption
            'Keine Gruppierung
            .BeginGroup = False
            'Beschriftung festlegen
            .Caption = strButtonCaption
            'Tooltip-Text festlegen
            .TooltipText = "Gespeicherte Ansicht laden und auf aktuellen Ordner übertragen"
            'Mit Makro verknüpfen
            .OnAction = "OLAN_AnsichtLaden"
        End With
    End If
    
    'Befehlsleiste sichtbar machen
    objCB.Visible = True
End Sub

Public Sub OLAN_AnsichtSpeichern()
    Dim objAktView As View
    Dim vntArray As Variant
    Dim strPräfix As String
    Dim objDialogOCX As Object
    Dim strDateiname As String

    'Fehlerverfolgung ausschalten
    On Error Resume Next
    
    'Verweis auf aktuelle Ansicht holen
    Set objAktView = ActiveExplorer.CurrentFolder.CurrentView
    
    'Zum ViewType der Ansicht passendes Dateinamenspräfix holen
    vntArray = Array("Table", "Card", "Calendar", "Icon", "Timeline")
    strPräfix = vntArray(objAktView.ViewType) & "_"

    'Verweis auf Dialoge.ocx holen
    Set objDialogOCX = CreateObject("Dialoge.MyControl")
    'Dateinamen zum Speichern abfragen
    strDateiname = objDialogOCX.FileSave("XML-Dateien", "*.xml", strPräfix & "MeineAnsicht.xml", "", "Ordneransicht speichern")
    'Wenn Dateiname gewählt und...
    If strDateiname > "" Then
        '... Datei bereits existiert und...
        If Dir(strDateiname) > "" Then
            '... User keine Erlaubnis zum Überschreiben gibt, dann...
            If MsgBox("Die Datei " & strDateiname & " existiert bereits. Überschreiben?", vbYesNoCancel + vbQuestion, "Ordneransicht speichen") <> vbYes Then
                '... Prozedur verlassen
                Exit Sub
            End If
        End If
        
        'Datei zum Schreiben öffnen
        Open strDateiname For Output As #1
        'XML-Schema der aktuellen Ansicht hineinschreiben
        Print #1, objAktView.XML
        'Datei schließen
        Close #1
    End If
End Sub

Public Sub OLAN_AnsichtLaden()
    Dim objDialogOCX As Object
    Dim strDateiname As String
    Dim objAktOrdner As MAPIFolder
    Dim strAnsichtName As String
    Dim objView As View

    'Fehlerverfolgung ausschalten
    On Error Resume Next
    
    'Verweis auf Dialoge.ocx holen
    Set objDialogOCX = CreateObject("Dialoge.MyControl")
    'Dateinamen zum Öffnen abfragen
    strDateiname = objDialogOCX.FileOpen("XML-Dateien", "*.xml", , , "Ordneransicht laden")
    'Wenn Dateiname gewählt, dann...
    If strDateiname > "" Then
        '... Name der benutzerdefinierten Ansicht festlegen
        strAnsichtName = "MeineAnsicht"
        
        'Verweis auf aktuellen Ordner holen
        Set objAktOrdner = ActiveExplorer.CurrentFolder
        'Verweis auf Ansicht "MeineAnsicht" holen
        Set objView = objAktOrdner.Views(strAnsichtName)
        'Wenn Ansicht schon existiert, dann...
        If Not objView Is Nothing Then
            '... zunächst löschen
            objView.Delete
            'Alle übrigen Ansichten der Reihe nach aktivieren,
            'damit Outlook die Bildschirmanzeige aktualisiert
            For Each objView In objAktOrdner.Views
                objView.Apply
            Next
        End If
            
        'Ansicht "MeineAnsicht" neu anlegen; der Typ entspricht
        'dem Präfix des Dateinamens
        Set objView = objAktOrdner.Views.Add(Name:=strAnsichtName, ViewType:=HolViewType(strDateiname))
        With objView
            'XML-Datei öffnen
            Open strDateiname For Input As #1
            'XML-Schema aus Datei in Schema der Ansicht kopieren
            .XML = Input(LOF(1), 1)
            'Datei schließen
            Close #1
            'Ansicht speichern und...
            .Save
            '... aktivieren
            .Apply
        End With
    End If
End Sub

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

Private Function HolViewType(strDateiname) As Integer
    Dim vntArray As Variant
    Dim intI As Integer
    
    'Array definieren
    vntArray = Array("Table", "Card", "Calendar", "Icon", "Timeline")
    'Alle Elemente durchlaufen
    For intI = 0 To UBound(vntArray)
        'Wenn Elementname im Dateinamen vorkommt, dann...
        If InStr(LCase(strDateiname), LCase(vntArray(intI)) & "_") > 0 Then
            '... Position innerhalb des Arrays zurückgeben
            HolViewType = intI
            'Schleife verlassen
            Exit For
        End If
    Next
End Function
