Sub sample()
Dim OkApp As Object 'OKはOutlookの略(笑)
Dim myNameSpace As Object
Dim myFolder As Object
Dim Sports As Object
Dim MyInbox As Object
Dim PrivateFolder As Object
Dim MyExplorer As Object
Dim MySelection As Object
Dim mailitem As Object
Dim i As Long
Set OkApp = CreateObject("Outlook.Application") 'Outlook 起動
Set myNameSpace = OkApp.GetNamespace("MAPI") '空間の指定?実際サポートしているのは【MAPI】だけの模様
Set myFolder = myNameSpace.GetDefaultFolder(6) 'フォルダーの指定(6)が受信トレイ(5)が送信済みのアイテム、
myFolder.display 'Outlookの画面を表示
Set MyInbox = myNameSpace.GetDefaultFolder(6) '←移動元である受信トレイ
Set PrivateFolder = MyInbox.Folders("移動先") 'メールの移動先を【移動先】フォルダーに指定
For i = myFolder.Items.Count To 1 Step -1 'メール件数を取得し変数【i】を1つずつ減らしていく
Set mailitem = myFolder.Items(i)
If mailitem.Subject = ("ここに件名を入力") Then 'Subject(件名)で移動先判断
Cells(i, 1).Value = mailitem.Body '【.Body】はメール本文、本文をセルに転記
Set PrivateFolder = MyInbox.Folders("移動先") 'メールの移動先を【移動先】フォルダーに指定
Set MyExplorer = myFolder.Items(i)
MyExplorer.Move PrivateFolder 'メールを移動
'-------二つ目の件名を指定する場合---- 一応コメントアウト -----
' ElseIf mailitem.Subject = ("ここに件名を入力") Then 'Subject(件名)で移動先判断
' Cells(i, 2).Value = mailitem.Body '【.Body】はメール本文、本文をセルに転記
' Set PrivateFolder = MyInbox.Folders("移動先2") 'メールの移動先を【移動先2】フォルダーに指定
' Set MyExplorer = myFolder.Items(i)
' MyExplorer.Move PrivateFolder 'メールを移動
'--------------------------------------
Else '件名1or件名2意外だった場合の処理
Cells(i, 3).Value = mailitem.Body '【.Body】はメール本文、本文をセルに転記
Set PrivateFolder = MyInbox.Folders("その他") 'メールの移動先を【その他】フォルダーに指定
Set MyExplorer = myFolder.Items(i)
MyExplorer.Move PrivateFolder 'メールを移動
End If
Next i '繰り返す
End Sub
コメントを残す