情シス担当の備忘録

VBA・労働法とか。

【OutlookVBA】メールの「名前を付けて保存」の効率化パターン①

【本記事の対象者】
メーラーOutlookである。
・事務の中に「メールの保存」があり、面倒だと思っている。
VBA開発ができる(許される)環境にある。

【本記事を読んだ結果できること】
・メールの「名前をつけて保存」が効率化できる。

【前提】
私は「Outlook研究所(https://outlooklab.wordpress.com/)」様を見てVBAの勉強をしました。
OutlookVBA(マクロ)を使うのが初めてで、設定をしたこともないという方は、
Outlook VBA マクロ、はじめの一歩 | Outlook 研究所の記事が参考になるかと思います。
特に、セキュリティに関することの設定や、クイックアクセスツールバーにマクロ実行用ボタンを用意することへの理解は必須になります。
なお、私は事務員でありSEではありません。
専門的な質問への回答はできませんので、ご承知ください。


メールの保存、面倒ですよね。
メールの保存を効率化したマクロを開発しましたので、ご利用いただければと思います。
なお、「こんな機能があればもっと便利」等があれば作成にチャレンジしたいので、コメントいただきたいです。

処理の流れは、以下の画像のようになります。
①保存したいメールをOutlook上で選択する。

f:id:cha-hanman:20200711170554p:plain

②あらかじめツールバーに作成しておいたマクロ実行用のボタンを押す

f:id:cha-hanman:20200711170851p:plain

③保存場所を選択する画面が現れるので、選択してOKをクリックする。
(プログラムの都合上Excelが起動します)

f:id:cha-hanman:20200711170934p:plain

④メールを保存するためのフォルダを作成するので、フォルダ名を決めます。

f:id:cha-hanman:20200711171049p:plain

⑤フォルダが作成されます。メール本文はtxtで保存されて、添付ファイルがある場合には添付ファイルも保存されます。

f:id:cha-hanman:20200711171749p:plain

⑥保存が完了した旨のダイアログが出ます。

f:id:cha-hanman:20200711174740p:plain


コードは以下のとおりです。
クイックアクセスツールバーにマクロ実行用のボタンを作成して
使っていただくと便利かと思います。

Sub メールを今から選ぶ場所に保存()

Dim appExcel As Object
Set appExcel = CreateObject("Excel.Application")


'ダイアログを表示して保存場所を決める
Dim strSavePathName As String
  appExcel.Visible = True
AppActivate ("Excel")
appExcel.WindowState = 2   
appExcel.WindowState = 1
With appExcel.FileDialog(msoFileDialogFolderPicker)
     If .Show = 0 Then
        appExcel.Visible = False 'Excelを消す
    Exit Sub
End If
strSavePathName = .SelectedItems(1)
appExcel.Visible = False  'Excelを消す
End With

'メールのセット
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
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, "*", "*")
                
'保存の際につけたいフォルダ名は場合によって違うので、
'Inputboxから設定する。
'デフォルトでメールの件名を表示する。
'ダイアログで指定されたフォルダに、インプットボックスで指定された
'名前のフォルダを作成して、メールの保存処理。
Dim strSaveFolderName As String
strSaveFolderName = InputBox("フォルダ名を入力してください。" _
& vbCrLf & "ここに入力した文字列がフォルダ名になります。", _
Default:="" & strSubject & "")
If strSaveFolderName = "" Then 'キャンセルされた時用。
Exit Sub
End If
                            
'同じメールが保存されてないかチェック
'(正確には、同じフォルダが作成されていないかチェック)
'あった場合は処理終了
strSavePathName = "" & strSavePathName & "\" & strSaveFolderName & ""
If Dir(strSavePathName, vbDirectory) = "" Then
MkDir strSavePathName
Else
MsgBox ("同じタイトルのメールが既に保存されています。" _
& vbCrLf & "確認してください。")
End
End If

'txtとして保存。「oltxt」は書かないと文字化けするみたい。
objItem.SaveAs strSavePathName & "\" & strSubject & ".txt", olTXT

'添付ファイルの保存処理
Dim objAttachment As Object
Dim strAttachSavePath As String

With objItem
For Each objAttachment In .Attachments
strAttachSavePath = strSavePathName & "\" & objAttachment
objAttachment.SaveAsFile strAttachSavePath
Next objAttachment
End With

MsgBox ("保存が完了しました。")
End Sub

以上です。
このコード中では、「フォルダ作成+本文txt+添付ファイル保存」でメールを保存しています。
しかし、msg形式でメールを保存している方もいるかと思います。
その場合は、「save as」の部分をいじっていただくことになります。

この記事が事務処理効率向上に寄与すれば幸いです。
またパターン②も書きます。