outlookメールの添付ファイルを削除するVBScriptを作ってみた

今回も、自分の仕事で使う目的で作成した、outlookを操作するVBScriptシリーズである。

これまで、以下のVBScriptをアップしてきた。

• outlookのメール一覧をExcelに貼り付けるためのVBScriptを作ってみた
• outlookからメールと添付ファイルを出力する（その２）

私の場合、会社のメールサーバの容量が限られているので、定期的にサーバ上のメールを削除し、過去メールはデータファイル（pstファイル）にバックアップしている。
その際、データファイルの容量を極力小さくするため、サイズが大きく、かつ保存する必要のない添付ファイルは個別に削除しているのだが、そのためには以下の操作をメールの数だけ繰り返す必要がある。

1. 対象メールを開く
2. 添付ファイルを右クリックして削除
3. メールを保存

そこで今回は、メールの添付ファイルを削除するVBScriptを作成してみた。

使い方は、以下の通りである。
まず、事前準備として、本記事の最後に添付されている「delete_attached_files_in_outlook.vbs」を任意の場所に置いておく。
あとは、outlook上で対象メールを選択した状態で（複数選択可）このファイルをダブルクリックし、確認ダイアログに回答するだけである。VBスクリプトなので、VBAと違いoutlookに組み込む必要はない。
途中で「１ファイルづつ確認しながら削除しますか？」と聞いてくるので、ここで「はい」を選択すると添付ファイル毎に メール件名、添付ファイル名、サイズ が表示されるので個別に削除するか否かを指定でき、「いいえ」を選択すると個別の確認はなく全添付ファイルが削除される。
また、outlookへのアクセス許可を求める以下のダイアログが表示された場合は「許可」を選択する。

　

以下がスクリプトである。

---

Option Explicit

Dim objOA, objSelection, objItm, objAtt, objAtts
Dim I, MyDlt, MyMsg, MyCnt, MyCnfm, MyChng, MyIdx

Set objOA = CreateObject("Outlook.Application")

Set objSelection = objOA.ActiveExplorer.Selection
If objSelection.Count = 0 Then
 MsgBox "メールが選択されていません。"
 WScript.Quit
Else
 MyMsg = "★★警告★★" & vbCrLf & "以下のメールの添付ファイルが削除されます。良いですか？"
 MyCnt = 0
 For I = 1 To objSelection.Count
  set objItm = objSelection.Item(I)
  If objItm.Attachments.count > 0 Then
   MyCnt = MyCnt +1
   MyMsg = MyMsg & vbCrLf & Right(Space(5) & MyCnt, 5) & ": "& objItm.Subject
  End If
 Next
 If (MyCnt = 0) Then
  MsgBox "添付ファイル付きのメールが1通も選択されていません。"
  WScript.Quit
 Else
  If MsgBox(MyMsg, vbYesNo) = vbNo Then
   WScript.Quit
  End If
 End If 
End If

MyCnfm= MsgBox ("１ファイルづつ確認しながら削除しますか？", vbYesNoCancel)
If MyCnfm = vbCancel Then
 WScript.Quit
End If

For I = 1 To objSelection.Count
 set objItm = objSelection.Item(I)
 Set objAtts = objItm.Attachments
 If objAtts.Count > 0 Then
  MyChng = vbNo
  MyIdx = 1
  While objAtts.Count > MyIdx - 1
   set objAtt = objAtts.Item(MyIdx)
   If MyCnfm = vbYes Then
    MyDlt = MsgBox ("以下のファイルを削除しますか？" & vbCrLf & "　メール件名[" & objItm.Subject & "]" & vbCrLf & "　ファイル名[" & objAtt.FileName & "]" & vbCrLf & "　サイズ[" & Round(objAtt.Size/1024) & "KB]", vbYesNoCancel)
    If MyDlt = vbCancel Then
     WScript.Quit
    ElseIf MyDlt = vbYes Then
     objAtts.Remove(MyIdx)
     MyChng = vbYes
    Else 'MyDlt = vbNo
     MyIdx = MyIdx + 1
    End If
   Else
    objAtts.Remove(MyIdx)
    MyChng = vbYes
   End If
  Wend
  If MyChng = vbYes Then
   '既読に変更
   objItm.UnRead = False
   '変更を保存
   objItm.Save
  End If
 End If
Next

---

ファイルのダウンロードは以下のリンクを右クリックで「保存」を選択（ファイルの文字コードは SJIS）

ダウンロード - delete_attached_files_in_outlook.vbs

では。