PC-HELP.CZ

Pěkně zdravím
Pro označování složek MS Outlooku 2010 barevnými ikonami (uloženy v c:\icons\) používám níže uvedené makra (už si nepamatuji kde jsem je našel).
Prosím o radu jak upravit, abych nemusel zadával celý název složky, ale např. aby všechny složky do Maďarska (označené HUN, viz poslední makro) byly modré.
díky
Milan



Function GetFolder(ByVal FolderPath As String) As Outlook.folder
' Returns an Outlook folder object basing on the folder path
'
Dim TempFolder As Outlook.folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolder_Error

'Remove Leading slashes in the folder path
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If

'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set TempFolder = Application.Session.Folders.Item(FoldersArray(0))

If Not TempFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = TempFolder.Folders
Set TempFolder = SubFolders.Item(FoldersArray(i))
If TempFolder Is Nothing Then
Set GetFolder = Nothing
End If
Next
End If
'Return the TempFolder
Set GetFolder = TempFolder
Exit Function

GetFolder_Error:
Set GetFolder = Nothing
Exit Function
End Function


Sub ColorizeFolderAndSubFolders(strFolderPath As String, strFolderColour As String)
' this procedure colorizes the folder given by strFolderPath and all subfolfers

Dim olProjectRootFolder As Outlook.folder
Set olProjectRootFolder = GetFolder(strFolderPath)

Dim i As Long
Dim olNewFolder As Outlook.MAPIFolder
Dim olTempFolder As Outlook.MAPIFolder
Dim strTempFolderPath As String

' colorize folder
Call ColorizeOneFolder(strFolderPath, strFolderColour)

' Loop through the items in the current folder.
For i = olProjectRootFolder.Folders.Count To 1 Step -1

Set olTempFolder = olProjectRootFolder.Folders(i)

strTempFolderPath = olTempFolder.FolderPath

'prints the folder path and name in the VB Editor's Immediate window
'Debug.Print sTempFolderPath

' colorize folder
Call ColorizeOneFolder(strTempFolderPath, strFolderColour)
Next

For Each olNewFolder In olProjectRootFolder.Folders
' recursive call
'Debug.Print olNewFolder.FolderPath
Call ColorizeFolderAndSubFolders(olNewFolder.FolderPath, strFolderColour)
Next

End Sub

Sub ColorizeOutlookFolders()

Call ColorizeFolderAndSubFolders("\\Ing. Milan \_LIVE", "red")
Call ColorizeFolderAndSubFolders("\\Ing. Milan \_LIVE\14501_CZE_PROV_KTMU1800", "magenta")
Call ColorizeFolderAndSubFolders("\\Ing. Milan \_LIVE\16149_HUN_Nitro_KTM1800", "blue")
Call ColorizeFolderAndSubFolders("\\Ing. Milan \_LIVE\17176_HUN_CHC2700", "blue")




End Sub