Outlookに送られる勤怠メールを抽出して月の稼働実績を算出する

常駐先にて、勤怠記録がメールで届くのですが、月の稼働実績を知る手段がなかったので
メールから出勤・退勤時刻を抽出して、稼働時間を計算し、結果をファイル生成するスクリプトを作りました。

Outlook限定だったり、メールからの抽出方法が汎用的ではないので
使える人はかなり限られていますが、久々にVBScriptを書いて学ぶことも多かったのでメモしておきます。

※エラー処理などは手抜きしてます。
ブラッシュアップしてまたアップします。

修正

2017/12/01 稼働時間を0.5時間単位の小数点以下切り捨てで計算（ex. 稼働時間：8.9 → 8.5）

使い方

1. vbsファイルをダブルクリック
2. 抽出したい月を入力（例：2017/08）
3. ファイルが出力される（例：201708_勤怠.txt）

kintaiMail.vbs

'設定 START ===============================================

Dim searchStr
searchStr = "登録時刻："

Dim syukkin
syukkin = "出勤登録"

Dim taikin
taikin = "退勤登録"

Dim outputMailFolder  '勤怠メール用の振り分けフォルダ名
outputMailFolder = "勤怠"

Dim breakTime  '休憩時間
breakTime = 60

'設定 END =================================================

Dim objFSO      'FileSystemObject
Dim objFile     'ファイル書き込み用
Dim oApp        'As Outlook.Application
Dim myNameSpace 'As Outlook.NameSpace
Dim myFolder    'As Outlook.Folder
Dim folderName
Dim mailList
Dim mail        'Itemsオブジェクト
Dim outputStr   '出力するファイル内容

'対象年月を設定
Dim targetMonth
targetMonth = InputBox("対象年月を入力してください。（例）2017/07")

If IsEmpty(targetMonth) Then
    WScript.Quit
ElseIf Not IsDate(targetMonth) Then
    WScript.Echo "正しい日付が入力されなかったため終了します。"
    WScript.Quit
End If

'ファイル名
Dim fileName
fileName = Replace(targetMonth, "/", "") & "_勤怠.txt"

'outlook起動
Set oApp = CreateObject("Outlook.Application")
Set myNameSpace = oApp.GetNamespace("MAPI")
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile(fileName)

'受信トレイの指定と表示
Set myFolder = myNameSpace.GetDefaultFolder(6)

'サブフォルダの数だけループする
For c = 1 To myFolder.Folders.Count
    Set subFolder = myFolder.Folders.Item(c)

    If subFolder.Name = outputMailFolder Then

        'メールを取得し、受信日時（昇順）でソート
        Set mailList = subFolder.items
        mailList.Sort "ReceivedTime", False

        'メールの件数分ループ
        For Each mail In mailList
            'メール本文から年月を取得
            nengetsu = Mid(mail.Body, InStr(mail.Body, searchStr) + Len(searchStr), 7)

            'メール本文から取得した年月 = 対象年月 の場合
            If targetMonth = nengetsu Then
               Dim day
               day = Mid(mail.Body, InStr(mail.Body, searchStr) + Len(searchStr), 10)

               If InStr(mail.Body, syukkin) <> 0 Then
                   If InStrRev(outputStr, "出勤")  > InStrRev(outputStr, "退勤") Then
                       outputStr = outputStr & vbLf
                   End If

                   outputStr = outputStr & day & "  " & _
                                   "出勤：" & Mid(mail.Body, InStr(mail.Body, searchStr) + Len(searchStr) + 10, 9) & "   "
               ElseIf InStr(mail.Body, taikin) <> 0 Then
                   If InStrRev(outputStr, "出勤")  < InStrRev(outputStr, "退勤") Then
                       outputStr = outputStr & day & "                    "
                   End If

                   outputStr = outputStr & "退勤：" & Mid(mail.Body, InStr(mail.Body, searchStr) + Len(searchStr) + 10, 9) & vbLf
               End If
            End If
        Next

        objFile.writeLine(outputStr)
        objFile.Close
    End If

Next

'読み取りモードで開く
Set objFile = objFSO.OpenTextFile(fileName, 1)

'合計稼働時間
Dim totalKadouTime

Do While objFile.AtEndOfStream <> True
    Dim readLine
    readLine = objFile.ReadLine

    If readLine <> "" Then
        Dim syukkinTime '出勤時刻

        If InStr(readLine, "出勤") <> 0 And InStr(readLine, "退勤") <> 0 Then
            syukkinTime = TimeValue(Mid(readLine, 16, 9))

            Dim taikinTime '退勤時刻
            Dim tmpTaikin

            Dim diffTime '退勤時刻 - 出勤時刻
            Dim kadouTime '稼働時間

            tmpTaikin = Mid(readLine, 32, 9)
            kadouTime = 0

            If tmpTaikin <> "" Then
                taikinTime = TimeValue(tmpTaikin)
                diffTime = (DateDiff("n", syukkinTime, taikinTime) - breakTime) / 60
                kadouTime = Round(diffTime * 2 - 0.5) / 2
            End If

            kintaiStr = kintaiStr & readLine & "  " & "稼動時間: " & kadouTime & vbLf
            totalKadouTime = totalKadouTime + kadouTime

        Else
           kintaiStr = kintaiStr & readLine & vbLf
        End If

    End If
Loop

'合計稼働時間を追加
If totalKadouTime <> "" Then
    kintaiStr = kintaiStr & vbLf & "合計稼働時間: " & totalKadouTime
End If

objFile.Close

'上書きモードで開く
Set objFile = objFSO.OpenTextFile(fileName, 2)
objFile.WriteLine(kintaiStr)

objFile.Close

WScript.Echo "ファイルが作成されました" & vbLf & fileName

'使用したオブジェクトの解放
Set oApp = Nothing
Set myNameSpace = Nothing
Set myFolder = Nothing
Set subFolder = Nothing
Set objFSO = Nothing
Set objFile = Nothing
Set kintaiFSO = Nothing
Set kintaiFile = Nothing

ファイル出力結果

打刻漏れ、もしくは出勤 or 退勤のみメールが取得できた場合は稼働時間は計算してません。