Option Explicit
 
''-------------------------------------------------------------------------
'' API-Deklarationen zum Lesen von Binär-Werten aus der Registrierung '' Nur für Outlook 2002/2003 erforderlich
''-------------------------------------------------------------------------
'Private Const KEY_READ As Long = &H20019 'Private Const HKEY_CURRENT_USER As Long = &H80000001 '
'Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
'        "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
'        ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As _
'        Long) As Long
'
'Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
'        "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
'        ByVal lpReserved As Long, lpType As Long, lpData As Any, _
'        lpcbData As Long) As Long
'
'Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
 
'-------------------------------------------------------------------------
' Datei zum Speichern und Wiederherstellen der Kategorien
'-------------------------------------------------------------------------
' XP:
'Private Const CATFILE As String = _
    "C:\Dokumente und Einstellungen\All Users\Dokumente\CategoriesTransfer.txt"
' Vista / 7:
Private Const CATFILE As String = _
    "C:\Users\Public\Documents\CategoriesTransfer.txt"
 
Public Sub ExportCategories()
 
    '=====================================================================
    ' Exportiert alle Kategorien aus der Standard-PST-Datei ab Outlook® 2007
    ' in eine Textdatei
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Dim objCategories As Object
    Dim objCategory As Object
    Dim lngFF As Long
 
    '---------------------------------------------------------------------
    ' Eventuell bereits vorhandene Export-Datei löschen
    '---------------------------------------------------------------------
    If Dir(CATFILE) <> "" Then Call Kill(CATFILE)
 
    '---------------------------------------------------------------------
    ' Freie Dateinummer ermitteln
    '---------------------------------------------------------------------
    lngFF = FreeFile
 
    '---------------------------------------------------------------------
    ' Export-Datei schreibend öffnen
    '---------------------------------------------------------------------
    Open CATFILE For Output As #lngFF
 
    '---------------------------------------------------------------------
    ' Verweis auf Kategorien-Objekt setzen
    '---------------------------------------------------------------------
    Set objCategories = Outlook.GetNamespace("Mapi").Categories
 
    '---------------------------------------------------------------------
    ' Alle Kategorien bearbeiten
    '---------------------------------------------------------------------
    For Each objCategory In objCategories
 
        With objCategory
 
            '-------------------------------------------------------------
            ' Haupteigenschaften in Export-Datei schreiben (Name, Farbe
            ' und Tastaturzugriff)
            '-------------------------------------------------------------
            Print #lngFF, .Name & ";" & .Color & ";" & .ShortcutKey
 
        End With
 
    Next
 
    '---------------------------------------------------------------------
    ' Export-Datei wieder schliessen
    '---------------------------------------------------------------------
    Close #lngFF
 
    '---------------------------------------------------------------------
    ' Meldung an Benutzer ausgeben
    '---------------------------------------------------------------------
    MsgBox "Exportierte Kategorien: " & objCategories.Count _
        , vbInformation + vbOKOnly
 
    '---------------------------------------------------------------------
    ' Objekte löschen
    '---------------------------------------------------------------------
    Set objCategories = Nothing
    Set objCategory = Nothing
 
End Sub
 
Public Sub ImportCategories()
 
    '=====================================================================
    ' Importiert Kategorien aus einer Textdatei (ab Outlook® 2007)
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2012-11-28 Version 1.1.0
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Dim objCategories As Outlook.Categories
    Dim vbResult As VbMsgBoxResult
    Dim strCategory As String
    Dim aryCategory() As String
    Dim lngFF As Long
    Dim lngCategories As Long
 
    '---------------------------------------------------------------------
    ' Verweis auf Kategorien-Objekt setzen
    '---------------------------------------------------------------------
    Set objCategories = Outlook.GetNamespace("Mapi").Categories
 
    '---------------------------------------------------------------------
    ' Sind Kategorien vorhanden?
    '---------------------------------------------------------------------
    If objCategories.Count > 0 Then
 
        '-----------------------------------------------------------------
        ' Vorhandene Kategorien löschen?
        '-----------------------------------------------------------------
        vbResult = MsgBox("Sollen die vorhandenen Kategorien gelöscht werden?", _
            vbQuestion + vbYesNoCancel + vbDefaultButton2, "Kategorien importieren")
 
        '-----------------------------------------------------------------
        ' Antwort auswerten
        '-----------------------------------------------------------------
        Select Case vbResult
            Case vbYes:
                If Not DeleteCategories(objCategories) Then GoTo ExitProc
            Case vbNo:
                ' Nichts machen
            Case vbCancel:
                GoTo ExitProc
        End Select
 
    End If
 
    '---------------------------------------------------------------------
    ' Freie Dateinummer ermitteln
    '---------------------------------------------------------------------
    lngFF = FreeFile
 
    '---------------------------------------------------------------------
    ' Import-Datei nicht vorhanden?
    '---------------------------------------------------------------------
    If Dir(CATFILE) = "" Then
        MsgBox "Die Importdatei """ & CATFILE & """ wurde nicht gefunden." _
            , vbCritical + vbOKOnly
        GoTo ExitProc
    End If
 
    '---------------------------------------------------------------------
    ' Import-Datei zum Lesen öffnen
    '---------------------------------------------------------------------
    Open CATFILE For Input As #lngFF
 
    '---------------------------------------------------------------------
    ' Import-Datei abarbeiten
    '---------------------------------------------------------------------
    Do While Not EOF(lngFF)
 
        '-----------------------------------------------------------------
        ' 1 Zeile der Import-Datei einlesen
        '-----------------------------------------------------------------
        Line Input #lngFF, strCategory
 
        '-----------------------------------------------------------------
        ' Zeileninhalt in ein Feld laden
        '-----------------------------------------------------------------
        aryCategory() = Split(strCategory, ";")
 
        '-----------------------------------------------------------------
        ' Prüfen, ob die Kategorie schon vorhanden ist (0=Name)
        '-----------------------------------------------------------------
        If Not CategoryExists(aryCategory(0)) Then
 
            '-------------------------------------------------------------
            ' Anzahl importierter Kategorien erhöhen
            '-------------------------------------------------------------
            lngCategories = lngCategories + 1
 
            '-------------------------------------------------------------
            ' Kategorie importieren (0=Name, 1=Farbe, 2=Tastaturzugriff)
            '-------------------------------------------------------------
            objCategories.Add aryCategory(0), aryCategory(1), aryCategory(2)
 
        End If
 
    Loop
 
    '---------------------------------------------------------------------
    ' Import-Datei wieder schliessen
    '---------------------------------------------------------------------
    Close #lngFF
 
    '---------------------------------------------------------------------
    ' Meldung an Benutzer ausgeben
    '---------------------------------------------------------------------
    If MsgBox("Importierte Kategorien: " & lngCategories & vbCrLf & _
        vbCrLf & "Importdatei jetzt löschen?", vbInformation _
        + vbYesNo + vbDefaultButton2) = vbYes Then Call Kill(CATFILE)
 
ExitProc:
 
    '---------------------------------------------------------------------
    ' Objekte löschen
    '---------------------------------------------------------------------
    Set objCategories = Nothing
 
End Sub
 
Private Function DeleteCategories(ByVal objCategories As Outlook.Categories) As Boolean
 
    '=====================================================================
    ' Löscht vorhandene Kategorien
    ' Ab Outlook 2007
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2012-11-28 Version 1.0.0
    '=====================================================================
    
    Dim intCategories As Integer
    Dim intIndex As Integer
    Dim intDeleted As Integer
    Dim intErrors As Integer
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Anzahl Kategorien ermitteln
    '---------------------------------------------------------------------
    intCategories = objCategories.Count
 
    '---------------------------------------------------------------------
    ' Alle Kategorien durchlaufen und löschen
    '---------------------------------------------------------------------
    For intIndex = intCategories To 1 Step -1
 
        '-----------------------------------------------------------------
        ' Fehler zurücksetzen
        '-----------------------------------------------------------------
        Err.Clear
 
        '-----------------------------------------------------------------
        ' Kategorie löschen
        '-----------------------------------------------------------------
        Call objCategories.Remove(intIndex)
 
        '-----------------------------------------------------------------
        ' OK?
        '-----------------------------------------------------------------
        If Err.Number = 0 Then
            intDeleted = intDeleted + 1
        Else
            intErrors = intErrors + 1
        End If
 
    Next
 
    '---------------------------------------------------------------------
    ' Meldung an Benutzer
    '---------------------------------------------------------------------
    If MsgBox("Kategorien vorher: " & intCategories & vbCrLf & vbCrLf & _
           "Gelöscht: " & intDeleted & vbCrLf & _
           "Fehler: " & intErrors & vbCrLf & vbCrLf & _
           "Kategorien nachher: " & objCategories.Count, _
           vbInformation + vbOKCancel, "Kategorien löschen") = vbOK Then
        DeleteCategories = True
    Else
        DeleteCategories = False
    End If
 
    '---------------------------------------------------------------------
    ' Objekte löschen
    '---------------------------------------------------------------------
    Set objCategories = Nothing
 
End Function
 
Private Function CategoryExists(ByVal strName As String) As Boolean
 
    '=====================================================================
    ' Prüft, ob die Kategorie "strName" schon vorhanden ist
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
 
    Dim objCategories As Object
    Dim objCategory As Object
 
    '---------------------------------------------------------------------
    ' Verweis auf Kategorien-Objekt setzen
    '---------------------------------------------------------------------
    Set objCategories = Outlook.GetNamespace("Mapi").Categories
 
    '---------------------------------------------------------------------
    ' Alle Kategorien durchlaufen
    '---------------------------------------------------------------------
    For Each objCategory In objCategories
 
        '-----------------------------------------------------------------
        ' Kategoriename schon vorhanden?
        '-----------------------------------------------------------------
        If objCategory.Name = strName Then
            CategoryExists = True
            Exit For
        End If
 
    Next
 
    '---------------------------------------------------------------------
    ' Objekte löschen
    '---------------------------------------------------------------------
    Set objCategories = Nothing
    Set objCategory = Nothing
 
End Function