【Outlook】【さくっと】定期開催されるスケジュールを一覧で出力する【マクロ】


©David Castillo Dominici

©David Castillo Dominici

 

背景・概要

毎週開催されるスケジュールをみんなにMLやSNSで通知するとき、Outlookの予定一つ一つの各項目をコピペしていくのはちょっとだるい。
そんな時にこのツール! あるキーワードや期間の条件で一致するものがあれば、自分のスケジュールを一覧形式(テキスト)で出力します。

機能

自分のoutlookスケジュールの内、件名または本文にヒットするキーワードで nヶ月分出力する機能(のOutlookマクロ)

機能を詳しく、デメリットなども含めて説明

本人のスケジュールから、キーワードを含むものを一定期間抽出し、ひとつずつ改行し曜日等も付けるなど整形して出力する機能のマクロです。

フォーマット例:

スケジュール一覧 : (2014/2/1~2014/3/1)

-------------
2014/2/10(月) 10:00~11:00 @501会議室[〇〇打ち合わせ]
2014/2/10(月) 13:00~14:00 @101会議室[昼会]
2014/2/11(火) 9:00~12:00 @ABCD社[◇◇ミーティング]

※会議名のキーワードを入れると同じ会議名だけリストアップされる

 

初回の設定

例によってOutlookのマクロエディターにコピペし、マクロ実行可能なセキュリティレベルにしておく。マクロ登録方法はこちら

マクロ起動する(Sub とついたExportMyCaldndarマクロを開発タブなどから起動する)と、ダイアログが出て件名などのキーワードを聞いてくるので入力してください。また今からざっとnヶ月分かも聞かれるので入力してください。そうすると csvに出力されます。あとはエクセルやエディタで整形して使ってください。

出力項目や出力フォーマット等は、好きな様にカスタマイズしてください。
ソース最後の方の strLineで スケジュール1件1件を  日付や件名等組み立てているところ(&でつないでいる箇所) 

読み取りでもバグがあったら少し危ないですが、他人のスケジュールの場合(権限があればだと思いますが)拾ってくるサンプルも付けました(’でコメントアウト↓)。テストは少ししかしてないです。

その他の注意点

  • 30件でリミットかけています。
  • csvファイル出力も可能なサンプルを付けてます。

ソース

github

'  自分の予定表を出力するマクロ
Public Sub ExportMyCaldndar()
    'Const MY_CSV_FILE_NAME = "c:\mycalendar.csv" ' エクスポートするファイル名を指定してください。
    Dim fldCalendar ' As Folder
    Set fldCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)

    Dim keyword As String
    Dim laterMonth As String
    keyword = InputBox("件名または本文のキーワードは?", "共有されている予定表のエクスポート", "重要")
    laterMonth = InputBox("何か月後まで(負:何か月前から)", "共有されている予定表のエクスポート", 3)

    ExportThisMonth fldCalendar, keyword, laterMonth '  MY_CSV_FILE_NAME
End Sub

   '  他人の予定を出力するマクロ
    'Const OTHERS_CSV_FILE_NAME = "c:\others.csv" ' エクスポートするファイル名を指定してください。

    'strUserName = InputBox("ユーザー名またはアドレスを入力してください", "共有されている予定表のエクスポート")
    'Set objRecip = Application.Session.CreateRecipient(strUserName)
    'objRecip.Resolve
    'If Not objRecip.Resolved Then
    'End If
    'Set fldCalendar = Application.Session.GetSharedDefaultFolder(objRecip, olFolderCalendar)
    'ExportThisMonth fldCalendar, OTHERS_CSV_FILE_NAME

'  共通ルーチンです。必ずこちらもコピーしてください。
Public Sub ExportThisMonth(fldCalendar, keyword As String, laterMonth As String)
 
    
    Dim strStart As String
    Dim strEnd As String
    Dim dtExport As Date
    Dim objFSO 'As FileSystemObject
    Dim stmCSVFile 'As TextStream
    Dim colAppts As Items
    Dim objAppt 'As AppointmentItem
    Dim strLine As String
    Dim message As String
    Dim i As Integer
    Dim maxItemsNum As Integer
    
      'from clipboard
  
  'Dim cpo As New MSForms.DataObject
  'cpo.GetFromClipboard
  'On Error GoTo Whoa
  
  'for browser launch
  'Dim objShell As Object
  'Set objShell = CreateObject("WScript.Shell")
  
  'Dim PARAM As String
  'PARAM = DataObj.GetText(1)
  'objShell.Run "http://sample.url.hoge?" + PARAM
      
    
    maxItemsNum = 30
    i = 0
    
    '
    dtExport = Now ' 来月の予定をエクスポートする場合は Now の代わりに DateAdd("m",1,Now) を使用します。
    ' 月単位ではなく任意の単位にする場合は以下の記述を変更します。
    If Val(laterMonth) < 0 Then
        strEnd = Year(Now) & "/" & Month(Now) & "/1 00:00"
        strStart = DateAdd("m", Val(laterMonth), CDate(strEnd)) & " 00:00"
    Else
        strStart = Year(Now) & "/" & Month(Now) & "/1 00:00"
        strEnd = DateAdd("m", Val(laterMonth), CDate(strStart)) & " 00:00"
    End If
    '
    'Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Set stmCSVFile = objFSO.CreateTextFile(strFileName, True)

    message = ""

    'MsgBox "" & strEnd
    ' CSV ファイルのヘッダです。出力するフィールドを増減する場合はこちらも変更してください。
    'stmCSVFile.WriteLine """件名"",""場所"",""開始日"",""開始時刻"",""終了日"",""終了時刻"",""分類項目"",""主催者"",""必須出席者"",""任意出席者"""

    Set colAppts = fldCalendar.Items
    colAppts.Sort "[Start]"
    colAppts.IncludeRecurrences = True
    Set objAppt = colAppts.Find("[Start] < """ & strEnd & """ AND [End] >= """ & strStart & """")


    While (Not objAppt Is Nothing) And i < maxItemsNum

        If InStr(objAppt.Subject, keyword) > 0 Or InStr(objAppt.Body, keyword) > 0 Then
            strLine = FormatDateTime(objAppt.Start, vbShortDate) & "(" & Mid("日月火水木金土", Weekday(objAppt.Start), 1) & ") " _
            & FormatDateTime(objAppt.Start, vbShortTime) & "~"
            If FormatDateTime(objAppt.End, vbShortDate) <> FormatDateTime(objAppt.Start, vbShortDate) Then
                strLine = strLine & FormatDateTime(objAppt.End, vbShortDate) & " "
            End If
            
            strLine = strLine & FormatDateTime(objAppt.End, vbShortTime) _
            & " @" & objAppt.Location & " [" & objAppt.Subject & "]"
            '""",""" & objAppt.Categories & _
            '""",""" & objAppt.Organizer & _
            '""",""" & objAppt.RequiredAttendees & _
            '""",""" & objAppt.OptionalAttendees & _
            '""""
'
       'stmCSVFile.WriteLine strLine
        message = message & vbCrLf & strLine
        End If

        i = i + 1
        Set objAppt = colAppts.FindNext
    Wend
    'stmCSVFile.Close

    'MsgBox "スケジュール一覧" & cbCRLF & message
    ' 取得した情報で予定アイテムを作成
    Set objAppt = Application.CreateItem(olNoteItem) '予定表でなければここの引数を変え適切に処理する
    'objAppt.Subject = "スケジュール一覧"

    objAppt.Body = "スケジュール一覧 : (" & strStart & "~" & strEnd & ")" & vbCrLf & "-------------" & vbCrLf & message
    
  
    'objAppt.Save
    objAppt.Display
  
End Sub
Delicious にシェア
Digg にシェア
reddit にシェア
LinkedIn にシェア
LINEで送る
email this
Pocket

4,778 views.



コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です