MS Outlook, barevné ikony složek

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

VOM
Level 1.5
Level 1.5
Příspěvky: 114
Registrován: srpen 10
Pohlaví: Muž
Stav:
Offline

MS Outlook, barevné ikony složek

Příspěvekod VOM » 20 zář 2017 13:21

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

Reklama
  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • MS Outlook - Hromadné vytvoření složek Příloha(y)
    od czTANIScz » 22 zář 2023 11:36 » v Kancelářské balíky
    6
    2675
    od czTANIScz Zobrazit poslední příspěvek
    23 zář 2023 22:34
  • WIN 10 přesunutí složek users na jiný disk
    od Richard_ZZR » 10 úno 2024 11:30 » v Windows 11, 10, 8...
    3
    698
    od petr22 Zobrazit poslední příspěvek
    10 úno 2024 13:26
  • Ikony změna
    od DanteJo94 » 14 srp 2023 10:26 » v Mobily, tablety a jiná přenosná zařízení
    0
    1603
    od DanteJo94 Zobrazit poslední příspěvek
    14 srp 2023 10:26
  • Nezobrazují se ikony na ploše Příloha(y)
    od liborsm » 04 úno 2024 14:48 » v Windows 11, 10, 8...
    12
    1744
    od šulda Zobrazit poslední příspěvek
    09 úno 2024 15:04
  • Žlutomodrý štít u ikony aplikace w11 Příloha(y)
    od PittnerJiri » 01 srp 2023 15:03 » v Windows 11, 10, 8...
    5
    2099
    od petr22 Zobrazit poslední příspěvek
    23 zář 2023 19:16

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 3 hosti