非IT企業に勤める中年サラリーマンのIT日記

非IT企業でしかもITとは全く関係ない部署にいる中年エンジニア。唯一の趣味がプログラミングという”自称”プログラマー。

Outlook/VBA: 受信トレイからフォルダに自動で振り分けるマクロを作った

   

このOutlookマクロは、未読メールは受信トレイに置いておき、見終わったら各フォルダに移動、という手順をやっている人に便利です。

受信時に未読状態でフォルダに移動したい人は、Outlookの自動振り分け機能を使った方が良いです。

僕の場合はメールの見逃しを避けるために、未読メールは一旦は受信トレイに集約しておくんですね。で、既読のもののみ各フォルダに移動しています。

ただ、1日50件以上も受信しているので、手作業だと結構時間がかかりすぎるので、マクロを作った次第です。

ある程度、メールが溜まったら(すべて既読状態にして)このマクロを起動すると移動でメールが移動してくれます。かなり便利です。

[ad#top-1]

完成形

以下がマクロを起動した際のメール振り分け中の画面です。

カウンターが現れて、あらかじめ設定しておいたフォルダに移動していきます。

 

ちなみにプログラムはGitHubにて公開中。

satoshi71/OutlookToFolder

 

Outlookの準備(設定など)

まずは個人フォルダをあらかじめ作っておきます。

会社のメールの状態を公開するわけにもいかないので、個人PCのOutlookを使ってこれから説明します。放置していたらGoogleとMicrosoftから通知がいっぱい来ていました。

 

これらをフォルダに振り分けるために、個人フォルダを以下のように作りました。右はわかりやすく構成図を示しています。

 

 

個人フォルダの作り方はこちらを参考にしてください。

 

Outlook/VBA

Outlookでマクロ(VBA)を作る場合の基本的なところは以下を参照ください。

 

また、メールをフォルダに移動する基本的なソースコードはこちらに書いています。今回はこれを応用します。

 

まず最初にUserformでカウンターを作ります。分母の部分がLabel2、分子の部分がLabel1となっています。

 

ソースコードは以下の通りです。

Function getFolder(psl)
  getFolder = ""
  If InStr(psl, "Google") > 0 Then getFolder = "Google"
  If InStr(psl, "Windows") > 0 Then getFolder = "Microsoft/Windows"
  If InStr(psl, "OneDrive") > 0 Then getFolder = "Microsoft/OneDrive"
  If InStr(psl, "Sway") > 0 Then getFolder = "Microsoft/Sway"
End Function

Sub toFolder()
  Set myapp = CreateObject("Outlook.Application")
  '受信トレイ
  Set i_Folder = myapp.Session.GetDefaultFolder(6)
  '受信トレイの内容を移動
  Dim oDest As Outlook.MAPIFolder 'フォルダー

  UserForm1.Show vbModeless
  UserForm1.Label2 = i_Folder.Items.Count
  UserForm1.Label1 = 0

  '受信トレイを全件処理
  cnt = 1
  For idx = i_Folder.Items.Count To 1 Step -1
    On Error GoTo CONTINUE

    psl = i_Folder.Items(idx).SentOnBehalfOfName
    sbj = i_Folder.Items(idx).Subject

    fld = getFolder(psl)
    If fld <> "" Then
      If InStr(fld, "/") > 0 Then
        f1 = Split(fld, "/")(0)
        f2 = Split(fld, "/")(1)
        Set oDest = Application.Session.Folders("個人用 Outlook データ ファイル").Folders(f1).Folders(f2)
        i_Folder.Items(idx).Move oDest
      Else
        Set oDest = Application.Session.Folders("個人用 Outlook データ ファイル").Folders(fld)
        i_Folder.Items(idx).Move oDest
      End If
    End If

CONTINUE:

    UserForm1.Label1 = cnt
    DoEvents
    cnt = cnt + 1
  Next idx

  Unload UserForm1

End Sub
 

 

振り分けフォルダーの設定

メールの振り分けは、getFolder(psl) 関数内で設定します。

If InStr(psl, “送信者名の一部”) > 0 Then getFolder = “フォルダ名”

If InStr(psl, “送信者名の一部”) > 0 Then getFolder = “フォルダ名/サブフォルダ”

のように送信者名に応じて振り分けるフォルダーを指定します。サブフォルダは1階層分だけ指定可能です。親フォルダ-と「/(スラッシュ)」で区切ってください。

以下が例ですが、メール送信者の名前に「Windows」が含まれていたら、Microsoftフォルダの子フォルダWindowsに移動するようになります。

If InStr(psl, “Windows”) > 0 Then getFolder = “Microsoft/Windows”

getFolder(psl) 関数を改めて掲載しておきます。この関数内をカスタマイズさい。

Function getFolder(psl)
  getFolder = ""
  If InStr(psl, "Google") > 0 Then getFolder = "Google"
  If InStr(psl, "Windows") > 0 Then getFolder = "Microsoft/Windows"
  If InStr(psl, "OneDrive") > 0 Then getFolder = "Microsoft/OneDrive"
  If InStr(psl, "Sway") > 0 Then getFolder = "Microsoft/Sway"
End Function
 

 

ソースコードはこちら!

satoshi71/OutlookToFolder

 

[ad#ad-1]

スポンサーリンク

 - Outlook, VBA