Outlook：作業時間を集計するマクロを作ってみた

　Outlook でスケジュール管理をしています。

　予定を管理するだけでなく、過去に使った時間を計算できないかと考えて、マクロを作成しました。

　自分で言うのも何ですが、なかなか便利にできたと思いますので、ご希望の方は使ってみてください。

　仕事の時間を計算するために作りましたが、学生さんなら、各科目をどれだけ勉強したか計測してみると良いと思います。
もう２●年前、まだ、中学生だったころ、各科目の勉強時間を集計してみたことがありました。
勉強時間が少ない科目は、テストの結果が悪く、勉強時間が多い科目は、テストの結果が良くなることが確認できました。（笑）

【集計方法】

　マクロの登録が完了すると、２つのマクロを呼び出せるようになります。
(1) SumThisMonth()
(2) SumSelectedTerm()

　(1) のSumThisMonth() を呼び出すと当月の、(2)のSumSelectedTerm()を呼び出すと、指定した期間の作業時間を集計して、集計結果をExcelで表示します。

　なお、「作業時間」として集計したい項目の件名の冒頭に「#」（半角シャープ）をつけておきます。

こんな感じ（↓）

集計するために、同じように全部で４件の項目をつくりました（↓）

この期間を集計すると、このような集計表（↓）が表示されます。

【マクロの登録方法】

まずは、outlook でマクロが使えるように設定して、、、とステップがあるのですが、Millefeuille さんが作成された「Outlook VBA マクロ、はじめの一歩 - Windows Live」というページで、とても詳しく説明されていますので、こちらを見て設定してください。

　私も、Millefilleさんの説明に従って、マクロを使えるように設定しました (^^;
　また、これ以上に上手に書けるとは思いません。。。

【Excelを呼び出すための一手間】

　Excel を呼び出すために、マクロの「参照設定」を行う必要があります。
VBAの編集画面から、「ツール」→「参照設定(R)」を選び、

「Microsoft Excel xx.x Object Library」にチェックを入れてください。
※下の画像は、チェックした後なので、リストの上の方に来ていますが、最初はアルファベット順に並んでいますので、もっと下のほうにあります。

【注意事項】
Outlook 2007 で作成しましたので、古いバージョンだと動かないかも知れません。
作業用のファイルを c:\temp に作成しますので、あらかじめ c;\temp というディレクトリを作っておいてください。

※ Public Sub SumCalendar(ByVal strStart As String, ByVal strEnd As String) の中の、
この部分、「 Const CSV_FILE_NAME = "c:\temp\spenthours.csv"」のファイル名を適宜変更していただいてもOKです。

　マクロの改変・転送は自由ですが、copyright 表記だけは、残しておいていただけると嬉しいです。

'copyright @ KIWATA Shin 

Public Sub SumThisMonth()
    'Calculate the hours spent for current month
    '当月に使った時間を集計する。

    strStart = Year(Now) & "/" & Month(Now) & "/1 00:00"
    
    strEnd = DateAdd("m", 1, CDate(strStart)) & " 00:00"

    Call SumCalendar(strStart, strEnd)
   
    
End Sub

Public Sub SumSelectedTerm()
    ' caluculate the hours spent for the designated period
    ' 指定された期間内に使った時間を集計する。
    
    Dim tmpStr
    Dim strStart As String
    Dim strEnd As String
    
Label1:

    tmpStr = InputBox("Input start date")

    If IsDate(tmpStr) Then
        strStart = tmpStr
    Else
        MsgBox ("please input again")
        GoTo Label1
    End If
    
    
Label2:
    tmpStr = InputBox("Input end date")
    
    If IsDate(tmpStr) Then
        strEnd = tmpStr
    Else
        MsgBox ("please input again")
        GoTo Label2
    End If
    
    Call SumCalendar(strStart, strEnd)
    
    
End Sub
    
Public Sub SumCalendar(ByVal strStart As String, ByVal strEnd As String)
    
    Dim objFSO 'As FileSystemObject
    Dim stmCSVFile 'As TextStream
    Const CSV_FILE_NAME = "c:\temp\spenthours.csv"
    Dim colAppts As Items
    Dim objAppt 'As AppointmentItem
    
    Dim sumAppt
    Set sumAppt = CreateObject("Scripting.Dictionary")
    
    Dim strLine As String
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    On Error GoTo MyError
    
    Set stmCSVFile = objFSO.CreateTextFile(CSV_FILE_NAME, True)
    
    stmCSVFile.WriteLine """Subject"",""minutes"",""start time"",""end time"""
'    stmCSVFile.WriteLine """件名"",""所要時間（分）"",""開始日時"",""終了日時"""
    
    Set colAppts = Application.Session.GetDefaultFolder(olFolderCalendar).Items
    colAppts.Sort "[Start]"
    colAppts.IncludeRecurrences = True
    Set objAppt = colAppts.Find("[Start] < """ & strEnd & """ AND [End] >= """ & strStart & """")
    
    While Not objAppt Is Nothing
        If Left(objAppt.Subject, 1) = "#" Then
        
            strLine = """" & objAppt.Subject & _
            """,""" & DateDiff("n", objAppt.Start, objAppt.End) & _
            """,""" & objAppt.Start & _
            """,""" & objAppt.End & _
            """"
            If sumAppt.Exists(AfterStar(objAppt.Subject)) Then
                sumAppt.Item(AfterStar(objAppt.Subject)) = sumAppt.Item(AfterStar(objAppt.Subject)) + DateDiff("n", objAppt.Start, objAppt.End) / 60
            Else
                sumAppt.Add AfterStar(objAppt.Subject), DateDiff("n", objAppt.Start, objAppt.End) / 60
            End If
            
            stmCSVFile.WriteLine strLine
        End If
        
        Set objAppt = colAppts.FindNext
    Wend
    stmCSVFile.WriteLine "-----"
    
        stmCSVFile.WriteLine """Subject"",""hours"""
'        stmCSVFile.WriteLine """件名"",""所要累計時間"""

    Dim i As Integer
    keys = sumAppt.keys
    
    For i = 0 To sumAppt.Count - 1
    
    strLine = """" & keys(i) & _
            """,""" & sumAppt.Item(keys(i)) & _
            """"
    stmCSVFile.WriteLine strLine
            
    Next i
    
    stmCSVFile.Close
    

'  Excel を開かなくて良い場合は、以下5行を削除
'  If you don't wish open the file by Excel, delete following 5 lines.

Dim xlApp As Excel.Application
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Open CSV_FILE_NAME
Set xlApp = Nothing

Exit Sub

MyError:

    If Err.Number = 70 Then
    
    MsgBox ("cannot open temporary file." & vbCrLf & _
    "please close it if opend.")
'    MsgBox ("テンポラリファイルが開けません。" & vbCrLf & _
    "既に開いているファイルを閉じてください。")
    
    Else
    MsgBox ("Error No:" & Err.Number & " is happend." & vbCrLf & _
    Err.Description & _
    "Operation is cancelled.")

'    MsgBox ("エラー番号:" & Err.Number & " が起こりました。" & vbCrLf & _
    Err.Description & _
    "処理は中断しました。")
    End If

End Sub
Public Function AfterStar(ByVal Words As String)

    Dim i As Integer
    For i = 2 To Len(Words)
    
        If Mid(Words, i, 1) = " " Then
        Exit For
        End If
        
        If Mid(Words, i, 1) = "　" Then
        Exit For
        End If
        
    Next i
    
    AfterStar = Mid(Words, 2, i - 2)
    
End Function