添付ファイルを保存するOutlookマクロとファイルを操作するVBS

f:id:teali_s:20211204093938p:plain

特定のフォルダに仕分けられた最新のメールを開く
メールの添付ファイル4つのうち、WordとPDFを保存
Wordを開く
PDFはリネーム（今日の日付を追加）→移動→開く
作業フォルダにあるExcelを開く
シートのロックを外し、フィルタを解除
非表示のシートを表示して選択

という処理を毎日夕方に行うことになり、手動でやると地味に手間がかかるので自動化しました。
添付ファイルの保存はOutlookマクロ、それ以降は他の人も使えるようにと考えVBSにしました。

添付ファイル保存（Outlookマクロ）
ファイル操作（VBS）
VBSの中身

添付ファイル保存（Outlookマクロ）

Sub 添付ファイルを保存するマクロ()
    Rem 受信トレイを取得
    Dim objInbox As Object: Set objInbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

    Rem 「定期」内の「定期サブフォルダ」を取得
    Dim objFolder As Object: Set objFolder = objInbox.Folders.Item("定期").Folders.Item("定期サブフォルダ")

    Rem 受信日を基準に最新のメールを取得
    Rem ※フォルダ内では日付順に並べているが、Items(1)では最新のメールが取得できない
    Dim Newtime As Date: Newtime = objFolder.Items(1).ReceivedTime '最新(仮)

    Dim lp As Integer: Dim itm As Integer
    For lp = 2 To objFolder.Items.Count
        Dim Oldtime As Date: Oldtime = objFolder.Items(lp).ReceivedTime

        Rem 最新(仮)より新しいメールがあったらそちらを最新(仮)にする
        If Newtime < Oldtime Then
            Newtime = Oldtime
            itm = lp
        End If

        Oldtime = objFolder.Items(lp).ReceivedTime
    Next

    Rem デスクトップに保存するためにパス取得
    Dim WS As Object: Set WS = CreateObject("Wscript.Shell")
    Dim DPath As String: DPath = WS.SpecialFolders("Desktop") & "\"

    Rem 「A.doc」「B.pdf」以外使わないので2つだけデスクトップに保存する
    Rem ※ 添付ファイルを全て保存したい場合は「If .Item(lp)〜」「End If」を消す
    With objFolder.Items(itm).Attachments
        For lp = 1 To .Count
            If .Item(lp).FileName = "A.doc" Or .Item(lp).FileName = "B.pdf" Then
                .Item(lp).SaveAsFile DPath & .Item(lp)
            End If
        Next
    End With

    Set objFolder = Nothing
    Set objInbox = Nothing

    Rem VBS実行
    Shell "WScript.exe VBSのフルパス"
End Sub

処理対象のメールは、あらかじめ仕分けルールを作成し、「定期」フォルダ内の「定期サブフォルダ」に入るようにしてあります。

こんな感じ↓
定期
└定期サブフォルダ

ファイル操作（VBS）

Option Explicit

Dim WS: Set WS = CreateObject("WScript.Shell")
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim DPath: DPath = WS.SpecialFolders("Desktop")
Dim SFolder: SFolder = "作業フォルダのフルパス"

Rem ①デスクトップから2つのファイルを削除
Rem マクロから実行した場合は「C.pdf」「D.pdf」が存在せずエラーが出るので、エラーを無視する処理を入れる
On Error Resume Next 'ファイルが存在しなくてもエラーを出さない
FSO.DeleteFile DPath & "\C.pdf"
FSO.DeleteFile DPath & "\D.pdf"
On Error GoTo 0 'エラーが出るようにする

Rem ②「B.pdf」に「yy.m.d」形式で今日の日付を追加(月日は自動的に1桁になる)
BName = "B（" & Right(Year(Date), 2) & "." & Month(Date) & "." & Day(Date) & "）.pdf"

Rem ③「B.pdf」を「B（yy.m.d）.pdf」にリネームしつつフォルダに移動してから開く
FSO.MoveFile DPath & "B.pdf", SFolder & "【PDF保存フォルダ】\" & BName
WS.Run FSO.GetFile(SFolder & "【PDF保存フォルダ】\" & BName)

Rem ④デスクトップにある「A.doc」を開く
Dim dcApp: Set dcApp = CreateObject("Word.Application")
dcApp.Documents.Open DPath & "\A.doc"
dcApp.Visible = True

Rem ⑤作業フォルダにあるExcel「E.xlsm」を開く
Dim xlApp: Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Open SFolder & "E.xlsm"
Dim bkE: Set bkE = xlApp.ActiveWorkbook

Rem ⑥-1フィルタ解除マクロを実行し、Sheet1のロックを解除し、非表示にしてあるSheet2を表示して選択する
If bkE.ReadOnly = False Then
    xlApp.Run "Module1.フィルタ解除マクロ"
    bkE.Sheets("Sheet1").UnProtect
    bkE.Sheets("Sheet2").Visible = True
    bkE.Sheets("Sheet2").Select
Else
    Rem ⑥-2誰かが「E.xlsm」を開いている場合は何もできないのでメッセージを表示して閉じる
    MsgBox "誰かが開いてる…"
    bkE.Close False
    xlApp.Quit
End If

VBSの中身

処理ごとにバラしてコピペできるようにしました。

デスクトップのパスを取得

Dim WS: Set WS = CreateObject("WScript.Shell")
Dim DPath: DPath = WS.SpecialFolders("Desktop")

デスクトップにあるファイルを指定する時はDPath & "\ファイル名"にするか、変数に入れる時に\をつけておく。

ファイルを移動する

Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.MoveFile "移動元のフルパス", "移動先のフルパス"

フルパスには名前も含む。移動先で別の名前を指定すれば、名前を変更しながらの移動が可能。
例：
CからDへ「test.txt」を移動し、名前を「test2.txt」にする
FSO.MoveFile "C:\test.txt", "D:\test2.txt"

ファイルをコピーする

Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.CopyFile "コピー元のフルパス", "コピー先のフルパス"

使い方はMoveFileと同じ。

ファイルを削除する

Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFile "削除するファイルのフルパス"

ファイルを開く

PDF

Dim WS: Set WS = CreateObject("WScript.Shell")
WS.Run "PDFファイルのフルパス"

Word

Dim dcApp: Set dcApp = CreateObject("Word.Application")
dcApp.Visible = True
dcApp.Documents.Open "Wordファイルのフルパス"

Excel

Dim xlApp: Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Open "Excelファイルのフルパス"

以下はExcelを開いた後の処理。

Excelブックが読み取り専用か確認して処理を変更

Dim bkE: Set bkE = xlApp.ActiveWorkbook
If bkE.ReadOnly = False Then
    '読み取り専用ではない
Else
    '読み取り専用
End If

Excelブックのシートを表示・選択

Dim bkE: Set bkE = xlApp.ActiveWorkbook
bkE.Sheets("シート名").Visible = True
bkE.Sheets("シート名").Select

Excelブックのマクロを実行

Dim xlApp: Set xlApp = CreateObject("Excel.Application")
'xlApp.Visible = True
xlApp.Workbooks.Open "Excelブックのフルパス.xlsm"
xlApp.Run "モジュール名.プロシージャ名"
'xlApp.Quit

xlApp.Visible = Trueにしない場合、裏に非表示のExcelが残り続けるのでxlApp.Quitなどで閉じる。

Excelを閉じる

bkE.Close False '保存しない
xlApp.Quit

ネムリヤモリ