20251007コード置き場

Option Explicit

'' **************************************************************
''機能名 : GetOutlookFolderByFullPathJP
''返り値 : Object（MAPIFolder）
''引数 :
'' strFolderPath As String … Outlookフォルダのフルパス
'' 例）"¥¥[e-mail]¥受信トレイ¥aフォルダ¥bフォルダ"
''機能説明 : 日本語環境のOutlookで、フルパス文字列からフォルダを取得する。
'' 先頭の "¥¥" や区切りの "¥" は自動で "" に正規化する。
'' ルート（アカウント名）→下位階層の順にフォルダを辿る。
'' **************************************************************
Public Function GetOutlookFolderByFullPathJP(ByVal strFolderPath As String) As Object
On Error GoTo EndProc

Dim olApp As Object
Dim olNs As Object
Dim objRoot As Object
Dim objCur As Object
Dim varParts As Variant
Dim i As Long
Dim strNorm As String
Dim strRoot As String

'****正規化****
strNorm = Replace(strFolderPath, "¥", "\")   '日本語環境の¥を\に
Do While Left$(strNorm, 1) = "\"             '先頭の\は全て除去（\\も含む）
    strNorm = Mid$(strNorm, 2)
Loop
strNorm = Trim$(strNorm)
If Right$(strNorm, 1) = "\" Then strNorm = Left$(strNorm, Len(strNorm) - 1)

If Len(strNorm) = 0 Then Err.Raise 5, , "フォルダパスが空です。"

varParts = Split(strNorm, "\")

'◇最上位（ルート＝アカウント名）を抽出
strRoot = CStr(varParts(0))

'****Outlookオブジェクト****
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")

'****ルートフォルダを特定****
'（複数データファイルがある環境を想定し、名前一致で探す）
Set objRoot = Nothing
Dim f As Object
For Each f In olNs.Folders
    If StrComp(f.Name, strRoot, vbTextCompare) = 0 Then
        Set objRoot = f
        Exit For
    End If
Next

If objRoot Is Nothing Then
    Err.Raise 5, , "ルートが見つかりません: " & strRoot & vbCrLf & _
                   "Outlook左ペインの最上位名（アカウント名）と一致させてください。"
End If

'****下位階層を順に辿る****
Set objCur = objRoot
For i = 1 To UBound(varParts)
    Set objCur = FindSubFolderByName(objCur, CStr(varParts(i)))
    If objCur Is Nothing Then
        Err.Raise 5, , "フォルダが見つかりません: " & varParts(i) & vbCrLf & _
                       "親: " & JoinLeft(varParts, i, "\")
    End If
Next i

'結果
Set GetOutlookFolderByFullPathJP = objCur

EndProc:

'終了処理
Set objCur = Nothing
Set objRoot = Nothing
Set olNs = Nothing
Set olApp = Nothing

'↓↓↓↓↓↓エラー処理用↓↓↓↓↓↓↓↓↓
If Err.Number <> 0 Then
    '（必要なら）標準モジュールで Public ERR_METHOD_NAME As String を定義して運用
    On Error Resume Next
    If Err.Number <> 0 Then
        '何もしない（ERR_METHOD_NAME未定義でも落ちないように）
    End If
    On Error GoTo 0
    Call Err.Raise(Err.Number, , Err.Description)
End If
'↑↑↑↑↑↑エラー処理用_終了↑↑↑↑↑↑

End Function

'' **************************************************************
''機能名 : FindSubFolderByName
''返り値 : Object（MAPIFolder）/ Nothing
''引数 :
'' parentFolder As Object … 親フォルダ
'' strName As String … 探す子フォルダ名
''機能説明 : 子フォルダ名を大文字小文字無視で一致検索して返す。
'' **************************************************************
Private Function FindSubFolderByName(ByVal parentFolder As Object, ByVal strName As String) As Object
On Error GoTo EndProc
Dim sf As Object
For Each sf In parentFolder.Folders
If StrComp(sf.Name, strName, vbTextCompare) = 0 Then
Set FindSubFolderByName = sf
Exit Function
End If
Next sf
EndProc:
End Function

'' **************************************************************
''機能名 : JoinLeft
''返り値 : String
''引数 :
'' varParts As Variant … Splitした配列
'' idx As Long … 結合終端インデックス（手前まで）
'' delim As String … 区切り文字
''機能説明 : 配列の0〜idx-1要素を結合して返す（親フォルダの表示に使用）。
'' **************************************************************
Private Function JoinLeft(ByVal varParts As Variant, ByVal idx As Long, ByVal delim As String) As String
Dim i As Long, s As String
For i = 0 To idx - 1
If i > 0 Then s = s & delim
s = s & CStr(varParts(i))
Next
JoinLeft = s
End Function