Outlookのフォルダアイコンを変える方法

探していて、やっと見つけました。
https://community.spiceworks.com/topic/135867-change-outlook-folders-colors-possible
ちょっとうまくいかないところがあったので修正しました。


標準モジュールを作成して、下記をコピーする。
Sub ColorizeOutlookFolders()内は、適当に変更する。
IconPathは、アイコンを置くフォルダを指定

Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\100-People", "blue")

の中の"\\Personal\Documents\000-Mgmt-CH\100-People"の部分は、該当フォルダを右クリック→プロパティの全般タブの中で「場所」として表示されている部分に続けて、必要なフォルダを記述する。この例だと、「場所」として"\\Personal"が表示されていて、それ以降の"\Documents\000-Mgmt-CH\100-People"は、アイコンを変更したいフォルダを記載している。
"blue"の部分は、アイコンのファイル名。拡張子は.icoが自動的に付加される。

Dim IconPath As String

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, "\")
    
    '"/" is returned as URL encoded string. 
    For i = 1 To UBound(FoldersArray, 1)
    FoldersArray(i) = Replace(FoldersArray(i), "%2F", "/", , , vbTextCompare)
    Next
    
    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 ColorizeOneFolder(FolderPath As String, FolderColour As String)
    Dim myPic As IPictureDisp
    Dim folder As Outlook.folder
  
    Set folder = GetFolder(FolderPath)
    Set myPic = LoadPicture(IconPath + FolderColour + ".ico")
    If Not (folder Is Nothing) Then
        ' set a custom icon to the folder
        folder.SetCustomIcon myPic
        'Debug.Print "setting colour to " + FolderPath + " as " + FolderColour
    End If
End Sub

Sub ColorizeFolderAndSubFolders(strFolderPath As String, strFolderColour As String)
    ' this procedure colorizes the foler 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()
    
    IconPath = "C:\icons"
    
    Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\100-People", "blue")
    Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\200-Projects", "red")
    Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\500-Meeting", "green")
    Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\800-Product", "magenta")
    Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\600-Departments", "grey")
    
    Call ColorizeFolderAndSubFolders("\\Mailbox - Dan Wilson\Inbox\Customers", "grey")

End Sub

続いて、ThisOutlookSessionの中で下記を定義する

Private Sub Application_Startup()
    ColorizeOutlookFolders
End Sub

なお、ColorizeFolderAndSubFolders関数はサブフォルダまで色付けしてしまうので、上位フォルダだけを色付けしたければ、ColorizeOneFolder関数を使う。
アイコンの作成には、Folderico (http://www.vector.co.jp/soft/dl/winnt/util/se496231.html) が便利。
適当にフォルダを作成し、隠しファイルを見えるようにしておく。Foldericoでアイコンを設定したら、そのフォルダ中に.icoファイルができているので適当に名前を変えて、うえで設定したIconファイル置き場においておけば良い。