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

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

タスクの起動をイベントプロシージャで監視して、起動したら起動時間を記録

タスクの終了をイベントプロシージャで監視して、終了したら起動時間と現在時間との差分を実働時間に記録

それとともに、起動時間と現在時間を利用して予定表に予定を出力。

今は１つのタスクにした監視ができないので、ここは要改善！

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

参考リンクはココ

https://outlooklab.wordpress.com/category/outlook-vba-%E3%83%9E%E3%82%AF%E3%83%AD/