西海岸より

つらつらざつざつと

Outlookのメールから本文抽出

昨日(文字列の前後の改行を削除するTRIM)のマクロの続き。
Outlookの[週報]というメールフォルダで各自の週報メールから[進捗ステータス]の箇所だけ取り出し、エクセルに貼付けたい。
実はこれがやりたかった。

ということでエクセルで動作するマクロを作成。(trimはその時にはまったところ)
実行すると新しいBookを自動作成し、Outlookから指定した数のメールを読み込み、特定箇所を抽出しBookに出力します。

もちろんメールフォーマットが統一されていることが前提で、(要設定)と書いてるところを環境に合わせて設定することで使えます。(ただし使う場合は自己責任でお願いします。)

Option Explicit

Sub ExtractMail()

    Dim olAPP As Object
    Dim ns As Object
    Dim mf As Object
   
    Dim mailCount As Integer
    Dim accessCount As Integer
    Dim maxAccessCount As Integer
   
    Dim startString As String
    Dim endString As String
   
    Dim oneMail As Object
    Dim mailItems As Object
    Dim receivedTime As String
    Dim subject As String
    Dim from As String
    Dim body As String
    Dim targetBody As String
    Dim startPoint As Integer
    Dim endPoint As Integer

    Dim nYLINE  As Integer
   
    Workbooks.Add   '新規ブックを作成する

    Set olAPP = CreateObject("Outlook.Application")
    Set ns = olAPP.GetNamespace("MAPI") ' Namespace オブジェクト
   
    '--------------------------------------------------------
    '(要設定)メールボックスの設定
    Set mf = ns.Folders("個人用フォルダ"). _
                Folders("受信トレイ").Folders("週報")
    '(要設定)抽出したい文字列の開始文字列
    startString = "【ステータス】"
    '(要設定)抽出したい文字列の最後文字列
    endString = "【"
    '(要設定)読み込むメール最大数(あまり多いと結果取得まで相当時間がかかる。。。)
    maxAccessCount = 30
    '--------------------------------------------------------
   
    '見出しを書き込む
    nYLINE = 1
    Cells(nYLINE, 1) = "受信日時"
    Cells(nYLINE, 2) = "差出人"
    Cells(nYLINE, 3) = "件名"
    Cells(nYLINE, 4) = "本文"
    nYLINE = nYLINE + 1

    accessCount = 0 '読み込むメール用のカウント
    mailCount = 0 '抽出できたメール用のカウント

    For Each oneMail In mf.Items
        accessCount = accessCount + 1
       
        'パースするメール数のチェック
        If accessCount > maxAccessCount Then
            GoTo outLoop
        End If
       
        '返信メール(Re:から始まるメール)はスキップ
        subject = oneMail.subject
        If InStr(subject, "RE:") = 1 Then
            GoTo nextLoop
        End If
       
        receivedTime = oneMail.receivedTime
        body = oneMail.body
        from = oneMail.SenderName
        targetBody = ""
       
        '抜き出す最初の箇所のインデックス検索
        startPoint = InStr(body, startString)
       
        '無い場合はスキップ
        If startPoint = 0 Then
            GoTo nextLoop
        End If
       
        startPoint = startPoint + Len(startString)
        
        '抜き出す最後の箇所のインデックス検索
        endPoint = InStr(startPoint, body, endString, 1)
       
        'ターゲットとする箇所の文字列抽出
        targetBody = Mid(body, startPoint, endPoint - startPoint)
       
        '出力
        Cells(nYLINE, 1) = receivedTime
        Cells(nYLINE, 2) = from
        Cells(nYLINE, 3) = subject
        Cells(nYLINE, 4).Value = NTRIM(targetBody)
        
        mailCount = mailCount + 1
        nYLINE = nYLINE + 1
nextLoop:
    Next oneMail
outLoop:
    Columns("A:E").EntireColumn.AutoFit
    Range("A1").Select
End Sub

'ここに昨日の記事のNTRIM関数の宣言を貼付ける

Excel VBA 逆引き辞典パーフェクト 2010/2007/2003対応

Excel VBA 逆引き辞典パーフェクト 2010/2007/2003対応