MS office outlook のメールを個別に他の場所に保存

質問

MS office outlook のメールを個別に他の場所に保存

outlookの受信や送信フォルダに溜まったメールを１件ドラッグし、他の場所にドロップすると、『件名.msg』というファイルができます。

これをまとめてやりたいのですが、そうすると、件名が同じものは『件名(1).msg』とかになってしまいます。

『日時_件名.msg』で保存したいのですが、何かいい手段はありませんか？

前任者からの引継ぎ資料が大量にメール上にあって、
添付も含めて、どこかにすぐに見れる状態で、共有ファイルサーバ上に保存し、前任者のアカウントは後で削除しないといけません。

回答No.1

10CubeLeaf · ベストアンサー

下記は現在 Outlook で表示しているフォルダのアイテムを C:\temp に保存するというマクロです。

Sub SaveCurrentFolderToDisk()
On Error Resume Next
Const SAVE_PATH = "c:\temp\" ' 保存するフォルダのパス。最後に必ず \ をつける
Dim objItem 'As MailItem
Dim strFileName As String
Dim i As Integer
Dim arrErrChars
Dim objFSO
arrErrChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
Set objFSO = CreateObject("Scripting.FileSystemObject")
' 現在表示中のフォルダすべてについて
For Each objItem In ActiveExplorer.CurrentFolder.Items
' ファイル名を受信日時と件名から作成
strFileName = Format(objItem.ReceivedTime, "yyyymmdd_hhmm_") & objItem.Subject
If Err.Number <> 0 Then
' エラーが発生したら受信日時ではなく最終更新日時とする
strFileName = Format(objItem.LastModificationTime, "yyyymmdd_hhmm_") & objItem.Subject
Err.Clear
End If
' ファイル名として不適切な文字を _ に置き換える
For i = 0 To UBound(arrErrChars)
strFileName = Replace(strFileName, arrErrChars(i), "_")
Next
' ファイル名が 260 文字を超えないようにする
strFileName = Left(SAVE_PATH & strFileName, 250)
' 同名のファイルがある場合の処理
If objFSO.FileExists(strFileName & ".msg") Then
i = 2
' (2) から始める
While objFSO.FileExists(strFileName & "(" & i & ").msg")
i = i + 1
Wend
strFileName = strFileName & "(" & i & ")"
End If
' ファイルをフォルダに保存
objItem.SaveAs strFileName & ".msg", olMSG
Next
End Sub