VBScript
Outlook

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

More than 1 year has passed since last update.

常駐先にて、勤怠記録がメールで届くのですが、月の稼働実績を知る手段がなかったので

メールから出勤・退勤時刻を抽出して、稼働時間を計算し、結果をファイル生成するスクリプトを作りました。

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 退勤のみメールが取得できた場合は稼働時間は計算してません。

image.png