エクセルVBA:Outlookメール文から宛先抽出

Option Explicit

Sub fChkParentFolder_Sub()

    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim olSelection As Outlook.Selection
    Dim Mailbody As String
    
    Dim olFolder As Folder
    Dim parentFolder As Object
    Dim folderPath As String
    Dim MSenderOrMReceiver As String

    ' Outlook から選択メールを取得
    Set olApp = Outlook.Application
    Set olSelection = olApp.ActiveExplorer.Selection

    If olSelection.count = 0 Then
        MsgBox "メールが選択されていません。"
        Exit Sub
    End If

    If Not TypeOf olSelection.Item(1) Is Outlook.MailItem Then
        MsgBox "選択されたアイテムはメールではありません。"
        Exit Sub
    End If

    Set olMail = olSelection.Item(1)
    Mailbody = olMail.body

    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
        MSenderOrMReceiver = "MSender"
    ElseIf InStr(1, folderPath, "送信", vbTextCompare) > 0 Then
        MSenderOrMReceiver = "MReceiver"
    Else
        MSenderOrMReceiver = "MSender"
    End If

    ' 名前抽出を実行
    Dim result As String
    result = fExtractNameInMail(MSenderOrMReceiver, Mailbody, olMail, "英語であなたの苗字", "日本語であなたの苗字")
    MsgBox "宛先: " & result

End Sub



Function fExtractNameInMail(MSenderOrMReceiver As String, Mailbody As Variant, mailsent As Outlook.MailItem, YouLstName As String, YouLstNameJp As String) 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
    Dim MailSenderAdr As String
    
    
    bodyText = Mailbody
    
    ' 本文を改行ごとに分割
    lines = Split(bodyText, vbCrLf)
    
    If InStr(1, MSenderOrMReceiver, "MSender", vbTextCompare) > 0 Then
        KeywordsArray = Array("です", "from", ",")
    ElseIf InStr(1, MSenderOrMReceiver, "MReceiver", vbTextCompare) > 0 Then
        KeywordsArray = Array("です", "Dear", ",")
    End If
    
    ' 先頭3行を結合（４行）
    Dim i As Integer, namefrombuf As String
    For i = LBound(lines) To Application.WorksheetFunction.Min(UBound(lines), 4)
        If i >= 0 Then
            
            namefrom = namefrom & " " & lines(i)
            namefrombuf = namefrom
            If InStr(1, namefrom, "です", vbTextCompare) Or InStr(1, namefrom, "申します", vbTextCompare) Then
                i = 100
                namefrom = Trim(namefrom)
                Exit For
            ElseIf InStr(1, namefrom, "from", vbTextCompare) Then
                namefrom = Trim(namefrom)
                i = 101
                Exit For
                
            'Fromが改行されている場合
            ElseIf InStr(1, namefrom, ",", vbTextCompare) Then
                namefrom = Trim(namefrom)
                Dim ii As Long
                 For ii = i To 2
                    
                    namefrom = namefrom & " " & lines(ii + 1)
                    namefrombuf = namefrom
                    
                    If InStr(1, namefrom, "from", vbTextCompare) Then
                        i = 101
                        namefrom = Trim(namefrom)
                        Exit For
                    End If
                    
                 Next
                Exit For
            End If
        End If
    Next i

    'メール本文が「●●さん、●●です」以外で宛先抽出できない場合
    '送信者表示名,シート上のあなたの名前から宛先名を判断
    
    If i <> 101 And i <> 100 Then
       'あなたの名前がnameinmail＝本文冒頭に「Dear あなたの名前」のように入っている場合、MailsenderNameを宛先に
       If InStr(1, namefrom, YouLstName, vbTextCompare) > 0 Or InStr(1, namefrom, YouLstNameJp, vbTextCompare) > 0 Then
            MailSenderAdr = mailsent.SenderName
       Else
            'それ以外の場合To宛先の人を宛先にする
            MailSenderAdr = mailsent.To
       End If
       
       If IsJPTexts(namefrom, "0.1") Then
    
        
        fExtractNameInMail = GetLastNameInMailAdr(MailSenderAdr, "ja")
        
        Else
        
        fExtractNameInMail = GetLastNameInMailAdr(MailSenderAdr, "en")
        
        End If
        Exit Function
    
    End If
    
     
     '’’’’’’’’’’’’’’’’’’’’’’’’’' 英語メールの場合処理追加必要’’’’’’’’’’’’’’’’’’’’’’’’’
     'MsgBox namefrom
    
    If i = 101 And InStr(1, MSenderOrMReceiver, "MSender", vbTextCompare) > 0 Then
        fExtractNameInMail = 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 = 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 And InStr(1, namefrom, ",", 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
Function GetLastNameInMailAdr( _
    Mailaddress As String, _
    Optional lang_JPorEN As String = "en" _
) As String

    Dim eng As String
    Dim jp As String
    Dim pos1 As Long, pos2 As Long
    Dim result As String
    Dim hasBracket As Boolean

    ' ()位置
    pos1 = InStr(Mailaddress, "(")
    pos2 = InStr(Mailaddress, ")")
    hasBracket = (pos1 > 0 And pos2 > pos1)

    ' =========================
    ' ()があるケース ()の中に日本語名がある表式を想定
    ' =========================
    
    If hasBracket Then

        ' 英語部分
        eng = Trim(Left(Mailaddress, pos1 - 1))

        ' 日本語部分
        jp = Mid(Mailaddress, pos1 + 1, pos2 - pos1 - 1)

        If LCase(lang_JPorEN) = "jp" Or LCase(lang_JPorEN) = "ja" Then
            jp = Replace(jp, "　", " ")
            GetLastNameInMailAdr = Split(Trim(jp), " ")(0)

        Else
            result = Split(Trim(eng), " ")(0)
            GetLastNameInMailAdr = StrConv(LCase(result), vbProperCase)
        End If

    ' =========================
    ' ()が無いケース
    ' =========================
    Else
        
        ' 英語（先頭単語）
        On Error Resume Next
        Mailaddress = Mid(Mailaddress, 1, InStr(1, Mailaddress, "@", vbTextCompare) - 1)
        eng = Mailaddress
        On Error GoTo 0
        
        ' < より前だけ使う（メール部分除去）
        If InStr(eng, "<") > 0 Then
            eng = Left(eng, InStr(eng, "<") - 1)
        End If

        result = Split(Trim(eng), " ")(0)
        GetLastNameInMailAdr = StrConv(LCase(result), vbProperCase)
        
        '日本語指定されている場合でメール文から日本語取得できない場合は翻訳
        'If LCase(lang_JPorEN) = "jp" Or LCase(lang_JPorEN) = "ja" Then
        
        'On Error Resume Next
        '    GetLastNameInMailAdr = TranslateTexts_DefJPandEN(GetLastNameInMailAdr, "en", "jp")
        'On Error GoTo 0
        'End If
        
    End If

End Function

Function GetSMTPAddress(mail As Outlook.MailItem) As String

    Dim sender As Outlook.AddressEntry
    Dim exchUser As Outlook.ExchangeUser
    
    Set sender = mail.sender

    If sender Is Nothing Then Exit Function

    ' Exchangeユーザーの場合
    If sender.Type = "EX" Then
        Set exchUser = sender.GetExchangeUser
        
        If Not exchUser Is Nothing Then
            GetSMTPAddress = exchUser.PrimarySmtpAddress
        Else
            GetSMTPAddress = ""
        End If

    Else
        ' 通常SMTP
        GetSMTPAddress = mail.SenderEmailAddress
    End If

End Function