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.
