OUTLOOK VBA クィックアクセスツールバー用 選択したメールをmsg形式で保存する

Explorer用

OUTLOOK研究所のVBAをさらに強化しました
　受信トレイ、送信済みアイテムを複数マウスで選択し、以下のマクロDownloadSelectMailItemを実行すると、ドキュメントフォルダにmsg形式で保存します。
　このとき、表題と日付でファイル名を構成しますが、ファイルにあってはいけない文字をユーザー定義関数でカットし、さらに15文字程度に省略し、送信なのか受信なのかをファイ名にいれます。

ファイル名の法則について

20170315013500S
年月日時刻そしてSが送信済みのメールです。受信はRです。このあと送信なら送信先、受信なら送信元のアドレスがきて、件名が入るようになっています。
メールアドレスは人数が多い場合、最初のメールアドレスだけ表示し、他は何人いるか示します。

OUTLOOK2016でMSGファイルを開くには

下書きにMSGファイルをドラッグアンドドロップして開いてください。Win10+64BitOutlook2016では関連付けすら拒否されましたが、下書きフォルダに入れると開きます。

DownloadSelectMailItem

Sub DownloadSelectMailItem()
Dim myItem As MailItem
Dim NS As NameSpace
Dim objOutlook
Dim olIns As Inspector
Dim EX As Explorer
Dim objFol As Outlook.Folder
'Dim FSO As New FileSystemObject
Dim FSO: Set FSO = CreateObject("Scripting.FIlesystemObject")
Dim tempFol As Object, strtempFOl As String
Dim strfile As String, strSender As String, Dt As Date
Dim strMal()
Dim adreadall As String
Dim objTempFile As Object, strBase
'Dim wDoc As Word.Document
Dim StrSPFolder As String, cnt As Integer
Dim oSFol As Object, RSChr As String, strSub As String
Dim objOlFolder As Outlook.Folder
Dim Ar As Variant, i As Long
Dim ArR() As Variant, iArR As Long, strRecip As String
Dim Reg: Set Reg = CreateObject("VBScript.RegExp")
Const SendFolderName As String = "送信済みアイテム"
Const ReceiveFolderName As String = "受信トレイ"
Const strSendChr = "S"
Const strReceiveChr = "R"

With CreateObject("WScript.Shell")
StrSPFolder = .SpecialFolders("mydocuments")
Set oSFol = FSO.GetFolder(StrSPFolder)
End With
'Set objOutlook = CreateObject("Outlook.Application")
Set NS = Application.GetNamespace("MAPI")
'Set myItem = Application.CreateItem(olMailItem)
'Set objFol = NS.GetDefaultFolder(olFolderInbox)
Set EX = ActiveExplorer
'Set olIns = ActiveInspector
Ar = Split(EX.CurrentFolder.FolderPath, "\")
cnt = 0: RSChr = ""
Do Until cnt = UBound(Ar)
If EX.CurrentFolder.Name = SendFolderName Then
RSChr = strSendChr: Exit Do
ElseIf EX.CurrentFolder.Name = ReceiveFolderName Or EX.CurrentFolder.Parent.Name = ReceiveFolderName Then
RSChr = strReceiveChr: Exit Do
End If
cnt = cnt + 1
Loop
If RSChr = "" Then Exit Sub
For Each myItem In EX.Selection
Dt = myItem.ReceivedTime
strSub = replaceNGchar("件名_" & Left(myItem.Subject, 15) & "_")
strfile = ""
'////sstrSenderの定義
strSender = ""
'////送信の場合
If RSChr = strSendChr Then
For iArR = 1 To myItem.Recipients.Count
ReDim Preserve ArR(1 To iArR)
strRecip = CStr(myItem.Recipients.Item(iArR))
'Set Reg = New RegExp 'VBscript regular Expressionを参照設定したら使う
Reg.Global = True
Reg.IgnoreCase = False
Reg.Pattern = "（.+?.）$"
strRecip = Reg.Replace(strRecip, " ")
ArR(iArR) = Replace(strRecip, " ", "", 1, -1, vbTextCompare)
'Set Reg = Nothing 'VBscript regular Expressionを参照設定したら使う
Next
If UBound(ArR) = 1 Then strSender = Replace(CStr(ArR(1)), "'", "", 1) & "_全" & "1名" Else strSender = Replace(CStr(ArR(1)), "'", "", 1) & "他" & UBound(ArR) - 1 & "名"
'////受信の場合
ElseIf RSChr = strReceiveChr Then
'Set Reg = New RegExp
strSender = Mid(CStr(myItem.Sender), 1, 10)
Reg.Global = True
Reg.IgnoreCase = False
Reg.Pattern = "（.+?.）$"
strSender = Replace(Replace(Reg.Replace(strSender, " "), " ", ""), "　", "")
'Set Reg = Nothing 'VBscript regular Expressionを参照設定したら使う
End If

'////ファイルの重複を回避
strBase = StrSPFolder & "\" & Format(CDate(Dt), "YYYYMMDDhhmmss") & RSChr & strSender & "_" & strSub
strfile = strBase & ".msg"
If FSO.FileExists(strfile) = True Then
i = 1
Do
If FSO.FileExists(strBase & "(" & i & ")" & ".msg") = False Then
strfile = strBase & "(" & i & ")" & ".msg"
myItem.SaveAs strBase & "(" & i & ")" & ".msg", olMSGUnicode
Exit Do
End If
i = i + 1
Loop
Else
myItem.SaveAs strfile, olMSGUnicode
End If
Next
GoTo Terminator
Terminator:
Set FSO = Nothing
Set Reg = Nothing

End Sub

Public Function replaceNGchar(ByVal sourceStr As String, _
Optional ByVal replaceChar As String = "") As String

Dim tempStr As String

tempStr = sourceStr
tempStr = Replace(tempStr, "\", replaceChar)
tempStr = Replace(tempStr, "/", replaceChar)
tempStr = Replace(tempStr, ":", replaceChar)
tempStr = Replace(tempStr, "*", replaceChar)
tempStr = Replace(tempStr, "?", replaceChar)
tempStr = Replace(tempStr, """", replaceChar)
tempStr = Replace(tempStr, "<", replaceChar)
tempStr = Replace(tempStr, ">", replaceChar)
tempStr = Replace(tempStr, "|", replaceChar)
tempStr = Replace(tempStr, "[", replaceChar)
tempStr = Replace(tempStr, "]", replaceChar)

replaceNGchar = tempStr
End Function