【OutlookVBA】メールの「名前を付けて保存」の効率化パターン③（エクセルに保存先のハイパーリンクを記載）

cha-hanman.hatenablog.com
cha-hanman.hatenablog.com

これまでも、OutlookVBAでの「名前を付けて保存」の自動化について書きました。
今回が3回目です。ちなみに今回は職場の違う部署の方から依頼されて作った機能です。

今回のテーマは上記「②」の拡張版です。
②ではメールの管理表があるという前提のもと、以下の処理を実行しました。
・所定のパスへのフォルダ作成
・作成したフォルダにメール本文をtxtで保存し、添付ファイルも保存する。
・管理表（Excel）にメールについての必要情報を記載する。

今回は、管理表（Excel）にメールの保存先へのハイパーリンクを張ってみます。
前提として、今回のマクロでも、OutlookからExcelをいじるので、VBEの「ツール」→「参照設定」から「Microsoft Excel 〇〇.〇　 Object Libraly」の追加が必要です。

先に、処理の流れを画像で説明します。
（ほぼほぼ、以前作った「パターン②」と同じです）

①メール管理表を開きます。

エクセルの中身はこんな感じの想定です。

②Outlookを開いてメールを選択し、マクロを実行します。

③メールが指定した保存先に保存され、Excel管理表に受信日・件名が書き込まれます。
このとき、件名が自動的にハイパーリンクになり、メールをクリックするとメールの保存先が開けます。


※メールに添付ファイルがある場合は添付ファイルも保存されます。

以下、コードです。

Sub MailSave()

Dim objExcel As Object
Set objExcel = GetObject(, "Excel.Application")

'メールを開いていれば開いているメールをオブジェクトとして扱い、
'開いていなけば、エクスプローラー上で選択しているメールを
'オブジェクトとして扱う。
Dim objItem As Object
If TypeName(Application.ActiveWindow) = "Inspector" Then
    Set objItem = Application.ActiveInspector.CurrentItem
Else
    Set objItem = ActiveExplorer.Selection(1)
End If
 

'StrSubjectにメールの件名をセットし、
'不正なファイル名の原因となる文字をReplace
'（あとでStrSubjectを利用してフォルダを作るため）
Dim StrSubject As String
StrSubject = objItem.Subject
StrSubject = Replace(StrSubject, " ", "")
StrSubject = Replace(StrSubject, ":", "：")
StrSubject = Replace(StrSubject, "\", "￥")
StrSubject = Replace(StrSubject, "/", "／")
StrSubject = Replace(StrSubject, "|", "｜")
StrSubject = Replace(StrSubject, "<", "＜")
StrSubject = Replace(StrSubject, ">", "＞")
StrSubject = Replace(StrSubject, "?", "？")
StrSubject = Replace(StrSubject, "*", "＊")

Dim WSkanri As Worksheet
Set WSkanri = objExcel.Workbooks("メール管理表.xlsm").ActiveSheet

'管理表の空白行を探す｡
Dim i As Long
i = 4
Do While WSkanri.Cells(i, "B") <> ""
    i = i + 1
Loop

'メール保存先に関する変数作成
'エクセルに設定してある保存先と件名をくっつけて
'メールの保存先パスを作成。
Dim StrMailSaveFolder As String
Dim StrMailSavePath As String

StrMailSaveFolder = WSkanri.Range("C2") 'エクセルシートから取得
StrMailSavePath = "" & StrMailSaveFolder & "\" & StrSubject & "\"
'フォルダ作成
If Dir(StrMailSavePath, vbDirectory) = "" Then
    MkDir StrMailSavePath
Else
    MsgBox ("同じタイトルのメールが既に保存されています。" _
    & vbCrLf & "確認してください。")
    Exit Sub
End If


'本文をtxtとして保存。
objItem.SaveAs StrMailSavePath & "\" & StrSubject & ".txt", olTXT

'添付ファイルの保存。
Dim objattachment As Object
Dim StrAttachSavePath As String

With objItem
    For Each objattachment In .Attachments
        StrAttachSavePath = StrMailSavePath & "\" & objattachment
        objattachment.SaveAsFile StrAttachSavePath
    Next objattachment
End With

   
'管理表への入力。
Dim StrRecievedDate As String

StrRecievedDate = Format(objItem.ReceivedTime, "yyyy/mm/dd")
'メールの受信日
With WSkanri
    .Cells(i, "B").Value = StrRecievedDate
    .Hyperlinks.Add Anchor:=WSkanri.Cells(i, "C"), Address:=StrMailSavePath, TextToDisplay:=StrSubject
End With


MsgBox "保存完了"

以上です。
この記事を偶然見つけた方のお役に立てれば幸いです。