• このエントリーをはてなブックマークに追加

以下の機能を新たに実装してみた。

  • Outlookタスクの実働時間の記録
  • Outlookタスクの予定表への出力

タスクの起動をイベントプロシージャで監視して、起動したら起動時間を記録
タスクの終了をイベントプロシージャで監視して、終了したら起動時間と現在時間との差分を実働時間に記録
それとともに、起動時間と現在時間を利用して予定表に予定を出力。

今は1つのタスクにした監視ができないので、ここは要改善!
File: ThisOutlookSection

Dim WithEvents myInspectors As Inspectors
Dim WithEvents myTaskItem As TaskItem
Private Sub Application_Startup()
  Set myInspectors = Outlook.Inspectors
End Sub
Private Sub myInspectors_NewInspector(ByVal Inspector As Inspector)
  If TypeName(Inspector.CurrentItem) = "TaskItem" Then
    Set myTaskItem = Inspector.CurrentItem
  End If
End Sub
 
'タスク起動
Private Sub myTaskItem_Open(Cancel As Boolean)
  '起動時間を記録
  Call TaskTrace_StartTimer
End Sub
 
'タスク終了
Private Sub myTaskItem_Close(Cancel As Boolean)
  ' 予定表にログを生成
  Call TaskLog_Create(myTaskItem.Subject)
  '実働時間を獲得
  myTaskItem.ActualWork = (myTaskItem.ActualWork + TaskTrace_GetActualWorkTime())
  Set myTaskItem = Nothing
End Sub

File: TaskTrace

'---------------------------------------------------------------------
'タスクの起動時間を実働時間に記録する
'---------------------------------------------------------------------
Option Explicit
 
Dim start_time
 
Public Sub TaskTrace_StartTimer()
  start_time = Now()
End Sub
 
Public Sub TaskTrace_StopTimer()
  start_time = 0
End Sub
 
Public Function TaskTrace_GetActualWorkTime()
  Dim current_actualwork_time
  TaskTrace_GetActualWorkTime = DateDiff("n", start_time, Now())
  start_time = 0
End Function
 
Public Function TaskTrace_GetStartTime()
  TaskTrace_GetStartTime = start_time
End Function

File: TaskLog

'---------------------------------------------------------------------
' 予定を生成
'---------------------------------------------------------------------
Public Sub TaskLog_Create(jobNAME As String)
  Dim fldCalendar As Folder
  Dim aITEM As AppointmentItem
 
  'フォルダ指定
  Set fldCalendar = Session.Folders("Outlook").Folders("予定表").Folders("TaskLog")
  Set aITEM = fldCalendar.Items.Add
 
  With aITEM
    .Subject = jobNAME
    .Body = "Samplebody"
    .Start = TaskTrace_GetStartTime()
    .End = Now
    .Save
  End With
End Sub

参考リンクはココ
http://outlooklab.wordpress.com/category/outlook-vba-%E3%83%9E%E3%82%AF%E3%83%AD/