OutlookVBA:本文から宛先抽出関数

Option Explicit


Function fChkParentFolder(olMail As MailItem)
    Dim olFolder As Folder
    Dim parentFolder As Object ' Parent は Object 型として扱う必要がある場合あり
    Dim folderPath As String
    
    ' Outlook アプリケーションのインスタンスを取得
    'Set olApp = Outlook.Application
    'Set olNamespace = olApp.GetNamespace("MAPI")
      
        ' 選択メールのフォルダを取得
        Set olFolder = olMail.Parent

        ' 現在のフォルダ名を取得
        folderPath = olFolder.Name
        
        ' 親フォルダを取得（ルートフォルダまで再帰的に）
        Set parentFolder = olFolder
        Do While Not parentFolder.Parent Is Nothing
            Set parentFolder = parentFolder.Parent
            If TypeOf parentFolder Is Outlook.Folder Then ' 型を確認してキャスト
                folderPath = parentFolder.Name & "\" & folderPath ' フォルダパスを構築
            Else
                Exit Do
            End If
        Loop

        If InStr(1, folderPath, "受信", vbTextCompare) > 0 Then
            fChkParentFolder = "MSender"
        ElseIf InStr(1, folderPath, "送信", vbTextCompare) > 0 Then
            fChkParentFolder = "MReceiver"
        Else ' 受信ボックスか送信済みボックス以外の場合は受信ボックスの処理
            fChkParentFolder = "MSender"
        End If
        
        Call fExtractNameInMail(fChkParentFolder, Mailbody)
  
End Function


Function fExtractNameInMail(MSenderOrMReceiver As String, Mailbody As Variant) As String
    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim olSelection As Selection
    Dim bodyText As String
    Dim MailSender As String
    Dim lines As Variant
    Dim namefrom As String
    Dim KeywordsArray() As Variant
    
    
    bodyText = Mailbody
    
    ' 本文を改行ごとに分割
    lines = Split(bodyText, vbCrLf)
    

     
    ' 先頭3行を結合（４行）
    Dim i As Integer
    For i = LBound(lines) To Application.WorksheetFunction.Min(UBound(lines), 4)
        If i >= 0 Then
            namefrom = namefrom & " " & lines(i)
            If InStr(1, namefrom, "です", vbTextCompare) Then
                namefrom = Trim(namefrom)
                Exit For
            ElseIf InStr(1, namefrom, "from", vbTextCompare) Then
                namefrom = Trim(namefrom)
                i = 100
                Exit For
            End If
        End If
    Next i
     
     '’’’’’’’’’’’’’’’’’’’’’’’’’' 英語メールの場合’’’’’’’’’’’’’’’’’’’’’’’’’
     
    If i = 100 And InStr(1, MSenderOrMReceiver, "MSender", vbTextCompare) > 0 Then
        fExtractNameInMail = "EngName " & Mid(namefrom, InStr(1, namefrom, "from", vbTextCompare) + 5)
        Exit Function
    ElseIf InStr(1, namefrom, "Dear", vbTextCompare) > 0 And InStr(1, namefrom, "from", vbTextCompare) > 0 Then
        fExtractNameInMail = "EngName " & " " & Mid(namefrom, InStr(1, namefrom, "Dear", vbTextCompare) + 5, InStr(1, namefrom, "san", vbTextCompare) - (InStr(1, namefrom, "Dear", vbTextCompare) + 5))
        Exit Function
    ElseIf InStr(1, namefrom, "Dear", vbTextCompare) > 0 Then 'And InStr(1, namefrom, "san", vbTextCompare) > 0 Then
    ' 送信者に送りたいときで、from送信者のような記載もない場合の名前抽出は未実装
        fExtractNameInMail = "EngName "
        Exit Function
    ElseIf InStr(1, namefrom, "san", vbTextCompare) > 0 Or InStr(1, namefrom, "Dear", vbTextCompare) > 0 Then
        fExtractNameInMail = "EngName "
        Exit Function
    End If

    
    Dim TrimedNamefrom As String
    
    KeywordsArray = Array(" ", "　", "、", vbCrLf, vbLf, vbCr, vbTab)
    TrimedNamefrom = namefrom

    TrimedNamefrom = Removekeywords(TrimedNamefrom, KeywordsArray)
    
    TrimedNamefrom = CompareToExtract(MSenderOrMReceiver, namefrom, TrimedNamefrom)
    Debug.Print TrimedNamefrom
    
    KeywordsArray = Array("です。", "です", "。", "、", "さん")
    'Debug.Print Removekeywords(TrimedNamefrom, KeywordsArray)
    TrimedNamefrom = Removekeywords(Trim(TrimedNamefrom), KeywordsArray)
    If InStr(1, MSenderOrMReceiver, "MSender", vbTextCompare) > 0 Then
        TrimedNamefrom = Mid(TrimedNamefrom, InStrRev(TrimedNamefrom, " ", , vbTextCompare) + 1)
    End If
    fExtractNameInMail = Trim(TrimedNamefrom)
    'MsgBox fExtractNameInMail

End Function


Function Removekeywords(text As String, removewords As Variant) As String
    Dim patterns As Variant
    Dim i As Integer

    ' 削除する文字列のリスト
    patterns = removewords
    
    ' 配列をループして置換
    For i = LBound(patterns) To UBound(patterns)
        text = Replace(text, patterns(i), "")
    Next i
    
    ' 結果を返す
    Removekeywords = text
End Function


Function CompareToExtract(MSenderOrMReceiver As String, original As String, trimmed As String) As String
    Dim i As Long
    Dim lengthOriginal As Long
    Dim lengthTrimmed As Long
    
    ' 元の文字列と削除後の文字列の長さを取得
    lengthOriginal = Len(original)
    lengthTrimmed = Len(trimmed)
    
    ' 短い方の長さまで比較
    For i = 1 To Application.WorksheetFunction.Min(lengthOriginal, lengthTrimmed)
        ' 先頭から異なる文字が見つかった場合
        If Mid(original, i, 1) <> Mid(trimmed, i, 1) Then
            If InStr(1, MSenderOrMReceiver, "MSender", vbTextCompare) > 0 Then
                ' その位置から文末までの文字列を削除
                CompareToExtract = Mid(original, i)
                Exit Function
            ElseIf InStr(1, MSenderOrMReceiver, "MReceiver", vbTextCompare) > 0 Then
                ' 先頭からその位置までの文字列を削除
                CompareToExtract = Left(original, i)
                Exit Function
            Else
                ' 先頭からその位置までの文字列を削除
                CompareToExtract = Mid(original, i)
                Exit Function
            End If
        End If
    Next i
    
    ' 異なる部分が見つからない場合
    CompareToExtract = original
End Function