OUTLOOK VBA クィックアクセスツールバー用 閲覧しているメールをmsg形式で保存する Inspector版

Inspector用

OUTLOOK研究所のVBAをさらに強化しました
今回のVBAはメールを開いて閲覧する画面（インスペクター、Inspector）のクィックアクセスツールバーに登録するものです。

Explore用との違い

メールをリストで見ている画面はExplorerと言います。ファイルを管理するのもExplorerなのでなんでこんな紛らわしいネーミングなのか謎ですが、完全に別のものです。Explorerに登録するマクロはこちらに登録するVBAマクロは前回のOUTLOOK VBA クィックアクセスツールバー用 選択したメールをmsg形式で保存するの方になりますので混同しないようにしてください。

機能とコピペの注意

以下のマクロDownloadCurrentMailtemをInspectorのクィックアクセスツールバーに登録し、実行するとドキュメントフォルダにmsg形式で保存します。
このとき、表題と日付でファイル名を構成しますが、ファイルにあってはいけない文字をカットし、さらに15文字程度に省略し、送信なのか受信なのかをファイ名にいれます。
　なお、前回のExplorer用をすでにコピペしている場合、下記のVBAマクロをそのままコピペするとユーザー定義関数が重複してエラーを起こすので、それより上だけコピペしてください。

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

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

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

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

DownloadCurrentMailItem

Sub DownloadCurrentMailItem()
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
Set myItem = olIns.CurrentItem
Stop
Ar = Split(myItem.Parent.FullFolderPath, "\")
cnt = 0: RSChr = ""
Do Until cnt = UBound(Ar)
If olIns.CurrentItem.Parent.FullFolderPath = SendFolderName Then
RSChr = strSendChr: Exit Do
ElseIf olIns.CurrentItem.Parent.FullFolderPath = ReceiveFolderName Or olIns.CurrentItem.Parent.FullFolderPath = ReceiveFolderName Then
RSChr = strReceiveChr: Exit Do
End If
cnt = cnt + 1
Loop
If RSChr = "" Then Exit Sub

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

GoTo Terminator
Terminator:
Set FSO = Nothing
Set Reg = Nothing

End Sub

'[OUTLOOK VBA クィックアクセスツールバー用 選択したメールをmsg形式で保存する](http://qiita.com/Q11Q/items/30f4234b9b191cf17618)をすでにコピペしている場合、以下は重複するので不要です
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

機能的な補足

• Explorerは複数選択したケースを想定する必要がありますが、Inspectorは不要です。
• このとき、現在アクティブなインスペクターはActiveinspector、開いているメールアイテムはCurrentItemになります
• さらに、CurrentItemがフォルダーのどこに入っているかはParent。fullfolderPathで知ることができます。
• 英語版の場合、受信トレイ、送信済みアイテムは英語Inbox,Sent itemsに書き換える必要があると思います。
• このどちらかであることを知るにはフォルダーを￥マーク（Qitaでは英語版のウィンドウズのようにスラッシュで表示される）でSplitして配列に入れて回転させる方法を使っています。
• この配列変数の使い方は定番の方法です。