« 2019年4月 | トップページ | 2019年8月 »

2019年5月の記事

2019年5月 3日 (金)

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

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

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


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

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

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

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

 Outlook_acceess_permission

 

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


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 ("1ファイルづつ確認しながら削除しますか?", 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

 

では。

| | コメント (0)

2019年5月 2日 (木)

outlookからメールと添付ファイルを出力する(その2)

以前の記事「outlookからメールと添付ファイルを抽出するVBScriptを作ってみた」で、outlookからメールと添付ファイルを取り出すVBScriptを紹介した。

そのバージョンでは、あらかじめ対象メールをoutlookの指定フォルダにコピーしておかなければならなかったが、今回、その改良版としてoutlook上で選択されたメールを対象とするように仕様変更したので紹介する。
なお、私が試した環境は、Windows7とoutlook2010の組合せのみである。

主な機能は以下の通りである。

  • outlookのメールを、msgファイルとして、Windowsの指定フォルダに出力する。ファイル名は「YYYYMMDD_HHMMSS_メール件名.msg」で YYYYMMDD HHMMSS はメールの受信日時である。
  • オプションで、メールの添付ファイルを同じフォルダ直下の「添付_YYYYMMDD_HHMMSS_メール件名」というフォルダの下に出力することも選択可能。更に、オプションで、添付ファイル出力後、メールの添付ファイルを削除し、代わりに「添付ファイルを出力したフォルダのパスを記載したテキストファイル(ファイル名「元の添付ファイルの保存先フォルダ.txt」)」をメールに添付することも可能。

使い方は、以下の通りである。
まず、事前準備として、本記事の最後に添付されている「export_from_outlook.vbs」を任意の場所に置いておく。
あとは、outlook上で対象メールを選択した状態で(複数選択可)、このファイルをダブルクリックするだけである。VBスクリプトなので、VBAと違いoutlookに組み込む必要はない。

ダブルクリック後の手順をもう少し説明する。

  1. ダブルクリックすると「n 通のメールが選択されています。続けますか?」ときいてくるので「はい」を選択する。
  2. 以下のダイアログが表示されるので、出力先(格納先)フォルダを選択する。なお、ダイアログの下の「フォルダー(F):」にフルパスを直接貼り付けても良い。

    Folder_dialog

  3. 「添付ファイルを取り出しますか?」というダイアログが表示されるので「はい」「いいえ」のいずれかを選択する。
    「いいえ」を選択した場合は msgファイルのみ、「はい」を選択した場合は msgファイルに加え添付ファイルも抽出される。
  4. 3で「はい」を選択した場合、「添付ファイルを削除しますか?」というダイアログが表示されるので「はい」「いいえ」のいずれかを選択する。「はい」を選択した場合、元のメールの添付ファイルは削除されるので注意。
  5. 4で「はい」を選択した場合、「保存先フォルダを記載したテキストファイルを添付しますか?」というダイアログが表示されるので「はい」「いいえ」のいずれかを選択する。ここで「はい」を選択した場合、元の添付ファイルは削除されるが、代わりに添付ファイルを出力したフォルダのパスを記載したテキストファイルが添付される。なお、いずれの場合も、元が添付ファイル付きメールの場合、抽出された msgファイルには添付ファイルが含まれている。
  6. outlookへのアクセス許可を求める以下のダイアログが表示されるので、「許可」を選択する。

    Outlook_acceess_permission 

手順は以上である。


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


Option Explicit

Dim objOA, objSelection, objShell, objFolder, objFSO, objItm, objAtt, objWss, objTxt
Dim MyDate, MyFileName, MyFolder, MySubFolder, MyMsgPath, YNCont, YNExt, YNDel, YNRplc, ENVtmp, MyTmpTxt, MyMsg, MyCnt, I

Const olMSG = 3
Const ErrReject = -2147467260

'添付ファイル格納サブフォルダ名の接頭語
Const PreWord = "添付_"
'元の添付ファイルの保存先フォルダを記載した添付ファイル名
Const AttFileName = "元の添付ファイルの保存先フォルダ.txt"

Set objOA = CreateObject("Outlook.Application")

Set objSelection = objOA.ActiveExplorer.Selection
If objSelection.Count = 0 Then
 MsgBox "メールが選択されていません。"
 WScript.Quit
Else
 YNCont = MsgBox(objSelection.Count & " 通のメールが選択されています。続けますか?", vbYesNo)
 If YNCont = vbNo Then
  WScript.Quit
 End If
End If

Set objShell = WScript.CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder( 0 , "フォルダを選択して下さい" , &h4050 , &h11)

If (objFolder Is Nothing) Then
 WScript.Quit
End If
MyFolder = objFolder.Items.Item.Path

'MsgBox "MyFolder = " & MyFolder

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
If Not(objFSO.FolderExists(MyFolder)) Then
 MsgBox("存在しないフォルダが指定されました")
 WScript.Quit
End If

MyCnt = 0
For I = 1 To objSelection.Count
 set objItm = objSelection.Item(I)
 If objItm.Attachments.count > 0 Then
  MyCnt = MyCnt + 1
 End If
Next

YNExt = vbNo
If MyCnt > 0 Then
 YNExt = MsgBox("添付ファイルを取り出しますか?", vbYesNoCancel)
 If YNExt = vbCancel Then
  WScript.Quit
 ElseIf YNExt = vbYes Then
  YNDel = MsgBox("添付ファイルを削除しますか?", vbYesNoCancel)
  If YNDel = vbCancel Then
   WScript.Quit
  ElseIf YNDel = vbYes Then
   YNRplc = MsgBox("保存先フォルダを記載したテキストファイルを添付しますか?", vbYesNo)
   If YNRplc = vbYes Then
    MyMsg = "★★警告★★" & vbCrLf & "以下のメールの添付ファイルが置き換えられます。良いですか?"
   Else
    MyMsg = "★★警告★★" & vbCrLf & "以下のメールの添付ファイルが削除されます。良いですか?"
   End If
   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 MsgBox(MyMsg, vbYesNo) = vbNo Then
    WScript.Quit
   End If 
  End If
 End If
End If

Set objWss = WScript.CreateObject("WScript.Shell")
ENVtmp = objWss.expandEnvironmentStrings("%TMP%")

For I = 1 To objSelection.Count
 set objItm = objSelection.Item(I)
 
 MyDate = objItm.ReceivedTime
 MyDate = Replace(MyDate, "/", "")
 MyDate = Replace(MyDate, ":", "")
 MyDate = Replace(MyDate, " ", "_")

 MyFileName = MyDate & "_" & objItm.Subject

 '使用禁止文字を置換する
 MyFileName = Replace(MyFileName, "?", "?")
 MyFileName = Replace(MyFileName, ":", ":")
 MyFileName = Replace(MyFileName, "/", "/")
 MyFileName = Replace(MyFileName, "\", "¥")
 MyFileName = Replace(MyFileName, "*", "*")
 MyFileName = Replace(MyFileName, """", "”")
 MyFileName = Replace(MyFileName, "<", "<")
 MyFileName = Replace(MyFileName, ">", ">")
 MyFileName = Replace(MyFileName, "|", "|")
 
 MyMsgPath= MyFolder & "\" & MyFileName & ".msg"
 
' MsgBox MyMsgPath
 
 Err.clear
 On Error Resume Next

 objItm.SaveAs MyMsgPath , olMSG
 
 If (Err.Number = ErrReject) Then
  MsgBox "終了します"
  WScript.Quit
 End If

 On Error Goto 0

 If (YNExt = vbYes) and (objItm.Attachments.count > 0) Then
  
  MySubFolder = MyFolder & "\" & PreWord & MyFileName

  If objFSO.FolderExists(MySubFolder) = True Then
   MsgBox "フォルダ " & MySubFolder & " は既に存在しています。"
  Else
   objFSO.CreateFolder(MySubFolder)
  End If

  For Each objAtt In objItm.Attachments
   objAtt.SaveAsFile MySubFolder & "\" & objAtt.FileName
  Next
  
  If YNDel = vbYes Then
   Set objAtt = objItm.Attachments
   While objAtt.Count > 0
    objAtt.Remove 1
   Wend
   '既読に変更
   objItm.UnRead = False
   '変更を保存
   objItm.Save
   
   If YNRplc = vbYes Then
    MyTmpTxt = ENVtmp & "\" & AttFileName
    Set objTxt = objFSO.OpenTextFile(MyTmpTxt, 2, true)
    objTxt.Write(MySubFolder)
    objTxt.Close
    objItm.Attachments.Add(MyTmpTxt)
    objItm.Save
    objFSO.DeleteFile MyTmpTxt, True
   End If
  End If
 End If
Next


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

ダウンロード - export_from_outlook.vbs

 

どうぞご自由に。

| | コメント (0)

« 2019年4月 | トップページ | 2019年8月 »