vba/excel/ outlook の特定フォルダのメール情報を取得しテキストとして保存

Outlookの特定フォルダのメール情報を取得してテキストファイルに保存

課題は次のとおり

• メールの件名が合致しなかった場合の処理
• CommandButton2_Click() はオマケ

お借りした情報

• Microsoft Scripting Runtime
• Microsoft Outlook x.0 Object Library(最新)

ソース(いろいろ準備中)

Private Sub CommandButton3_Click()

  Set objoutlook = New Outlook.Application
  Set myNameSpace = objoutlook.GetNamespace("MAPI")
  
  ' ------------
  ' filesystemobject
  ' ------------
  Set myfso = New FileSystemObject
  
  p = 11
  r = 13
  
  For Each i In myNameSpace.Folders
    For Each j In i.Folders
      If j = "DIRECT" Then
        Cells(11, 1) = j
        Cells(11, 2) = j.Items.Count
        
        For Each k In j.Items
          '--- [ EXCEL ] ---
          Cells(r, 1) = k.Subject
          Cells(r, 2) = k.SenderName
          Cells(r, 3) = k.SenderEmailAddress
          Cells(r, 4) = Replace(k.Body, vbCrLf, "<br>")
          '--- [ REG ] ---
          
          '--- [ TEXT FILE ] ---
          Set myfile = myfso.CreateTextFile("C:\path\to\" & gethostname(k.Subject) & ".txt", True, True)
          'myfile.WriteLine ("===[Begin]================")
          myfile.WriteLine ("subject: " & Cells(r, 1))
          myfile.WriteLine ("user: " & Cells(r, 2))
          myfile.WriteLine ("from_address: " & Cells(r, 3))
          myfile.WriteLine ("body: " & k.Body)
          'myfile.WriteLine ("===[END]================")
          myfile.Close
          
          r = r + 1
        Next
      End If
    Next

  Next

'
  Set myfile = Nothing
  Set myfso = Nothing
  
  Set objoutlook = Nothing
  Set myNameSpace = Nothing

End Sub

Private Sub CommandButton2_Click()

  starty = 13
  xstart = 1
  xfin = 4
  
  ' start_cell; (y,x) = ( starty, 1)
  ' end___cell; (y,x) = ( cells(rows.count,1).end(xlup), xfin)
  
  
  lastY = Cells(Rows.Count, 1).End(xlUp).Row
  Cells(2, 3) = lastY
  
  Range(Cells(starty, 1), Cells(lastY, xfin)).ClearContents

End Sub