Recent, pe forumul TechNet US apăruse un topic în care se regăsea un cod ce permitea realizarea operaţiei de import/export a categoriilor de culori.

Update:  din motive necunoscute, moderatorii au şters acel articol.

În Microsoft Office 2003, acestea puteau fi exportate direct din regiştrii: HKEY_CURRENT_USERSoftwareMicrosoftOffice14.0OutlookCategories.

Începând cu Microsoft Office 2007 şi continuând cu Microsoft Office 2010, aceste categorii de culori se regasesc în fişierul personal *.pst.

Acum intervine întrebarea: de ce aş vrea să le export din moment ce le am în acel fişier personal ?
Aici, eu, ofer două răspunsuri:

  • dacă fişierul personal atinge limita maximă admisă, nu stau să le refac manual;
  • dacă vreau să le mut pe alt PC, la fel, nu vreau să le refac manual.
 
Eu am modificat codul pentru a salva acele log-uri pe Desktop, nu în folder-ul Temp, fiindcă vreau să îmi fac şi un back-up al acelor categorii.
 
Codul pentru export este:
' Add Reference to Windows Script Host Object Model
Option Explicit
Const ForAppending = 2
Dim fso As FileSystemObject
Dim fso1 As FileSystemObject
Dim logfile1 As String
Dim logfile2 As String
Dim objLog1 As Object
Dim objLog2 As Object
Dim oLog3 As file
Dim oLog4 As file
Dim ts1 As TextStream
Dim ts2 As TextStream
Private Sub getCategoryInfo()  'gets categories –names and colors. Write names to one log and colors to another log.
    logfile1 = Environ("USERPROFILE") & "DesktopOutlook-category names.log"   'writes the log into the Desktop folder
    logfile2 = Environ("USERPROFILE") & "DesktopOutlook-category colors.log"
    Set fso = New FileSystemObject
    Set objLog1 = fso.CreateTextFile(logfile1, 2, True)    'creates the file if none found at the location and appends to the file if one is exists
    Set objLog2 = fso.CreateTextFile(logfile2, 2, True)  'creates the file if none found at the location and appends to the file if one is exists
    Dim oapp As Outlook.Application
    Dim categories As Outlook.categories
    Dim strNames As String    ' the category name
    Dim strColors As String    ' the category's color number
    Dim intNames As Integer
    Dim intColors As Integer
    Dim i As Integer
    Set oapp = New Outlook.Application
    Set categories = Outlook.GetNamespace("MAPI").categories
    On Error Resume Next
    For i = 1 To categories.Count
        strNames = strNames & "," & categories.Item(i).Name
        strColors = strColors & "," & categories.Item(i).Color
        intNames = Len(strNames)
        intColors = Len(strColors)
    Next
    strNames = Right(strNames, Len(strNames) - 1)    'removes the leading comma
    strColors = Right(strColors, Len(strColors) - 1)    'removes the leading comma
    objLog1.WriteLine strNames
    objLog2.WriteLine strColors
    Set oapp = Nothing
    objLog1.Close
    objLog2.Close
    Set objLog1 = Nothing
    Set objLog2 = Nothing
    Set fso = Nothing
End Sub

Codul pentru import este:

' Add Reference to Windows Script Host Object Model
Private Sub addinCategories()   'takes the log files created above and adds the categories into Outlook
    logfile1 = Environ("USERPROFILE") & "DesktopOutlook-category names.log"
    logfile2 = Environ("USERPROFILE") & "DesktopOutlook-category colors.log"
    Set fso1 = New FileSystemObject
    Set oLog3 = fso1.GetFile(logfile1)
    Set oLog4 = fso1.GetFile(logfile2)
    Set ts1 = oLog3.OpenAsTextStream(ForReading, TristateUseDefault)
    Set ts2 = oLog4.OpenAsTextStream(ForReading, TristateUseDefault)
    Dim strNames As String
    Dim strColors As String
    strNames = ts1.ReadLine
    strColors = ts2.ReadLine
    Dim olkApp, olkSes, olkCats, olkCat, arrCats, varCat, arrColors, varColor, intIndex
    Set olkApp = New Outlook.Application
    Set olkCats = olkApp.Session.categories
    arrCats = Split(strNames, ",")
    arrColors = Split(strColors, ",")
    On Error Resume Next
    For intIndex = LBound(arrCats) To UBound(arrCats)
        varCat = arrCats(intIndex)
        varColor = arrColors(intIndex)
        Set olkCat = olkCats.Item(varCat)
        If TypeName(olkCat) = "Nothing" Then
            Set olkCat = olkCats.Add(varCat, varColor)
        Else
            If olkCat.Color <> varColor Then
                olkCat.Color = varColor
            End If
        End If
    Next
    oLog3.OpenAsTextStream.Close
    oLog4.OpenAsTextStream.Close
    ts1.Close
    ts2.Close
    Set fso1 = Nothing
    Set olkCat = Nothing
    Set olkCats = Nothing
    Set olkApp = Nothing
End Sub

După rularea codurilor, categoriile vor fi exportate şi apoi importate în Outlook.

 

Back To Top
Search