【作業効率化】メール本文からスケジュール登録をワンクリックで行うマクロ[outlook]【おすすめ】


©digitalart

©digitalart

メールからスケジュールを頑張って登録してみるoutlookマクロ

会議の打ち合わせメールを受信した時に手動で
一々日付、時間、場所、議題、内容をコピペするのは面倒くさい!!

そんな時!!


このマクロは、ボタンひとつでメール内にあるテキストで、
一番上にあるスケジュールらしきものを、そこそこ気を使って登録してくれる機能です。

余計な頭を使わずに済むので、何か他のことを考え中でもアイデアを忘れないまま
スケジュールの登録作業が簡単にできます。
スケジュール作ると今考えてたものや、やろうとしていたことが頭から消えることがよくありますよね。。。
ぼけてるとは言わないでください。。

Google Calendar の Firefox 拡張機能版(Event Regist helper on google calendar.)を作りました。

本当に本当におすすめ!!

結構個人的にお気に入りの機能で
会社でもよく使っています。

このマクロがあれば、楽すぎます。
手放せません。

逆にこれがないと面倒だし
今やっている作業の重要なことを忘れてしまいます。

だからおすすめですよ!

機能

メール本文からワンクリックでスケジュール登録するための機能。

ほぼ自動です!


メールが来た→スケジュールあるな→ぽちっとな(※)→0.1秒でスケジュール登録完了
※ボタンにマクロを登録している場合

使い方

対象のメールを選択中にマクロを実行するだけ。
マクロは日付や議題っぽいフォーマットを見つけ、
過不足情報などを考慮し少し気を使って
Outlookのスケジュール帳に登録します。 

※セレクションによる指定機能はありません。今選択しているメールに対して動作します。

抽出可能なサンプルフォーマット

◇例1
議題:○○○を△△といい感じにする検討
場所:本社 8F C会議室
時間:6/1(金) 13:00~14:00

◇例2
【開催日】:2011年1月14日 8時30分
【アジェンダ】:○○○を△△で実現する調整
【場  所】:未定

◇例3
日 付:5月14日 8:30~  AAAの打ち合わせ@本社
  ・・・@はマクロで認識させてないです。

議題はアジェンダや目的でも良いですし、ない場合やメール件名から取得します。終了時間がなくても一応取ってこれます。

このマクロでは最後はOutlookにスケジュール登録していますが、その処理の部分を置き換えて例えばテキストとして他の機能を起動させられたりすれば他のスケジュールソフトと連携できるかもしれません。

デメリットやケースによりけりな機能

クリップボードが使えないため、最初の一つ目のスケジュールを選んでしまいます。
議題など明確な単語を優先しているので、ぜんぜん違うところからコピペされる可能性があります。
重要そうな単語のフォーマットを優先しています。件名等はなければメール件名を利用したり、終了時間もなければ開始時間を指定しています。

その他注意点等

2010 Exchangeサーバ上でも試しています(メールはローカルでも可能)。
その他ローカル環境でどこまでうまくいくかチェックしていません。

初回設定

Outlook の開発タブの Visual Basic Editor にコピペします。
セキュリティレベルをマクロ実行可能レベルにしておきます。
あとは、outlookのアプリケーションや、メールウインドウなど個別のクイックツールアクセスバーに登録しておくと、更に便利です。私はこのマクロで設定し、アイコンをスケジュールぽいものに変更しています(2010以降の場合)
15分前アラームなど好きに設定してください。

マクロ登録方法はこちら

実行時はマクロを実行するだけ。Subとついている選択メールのスケジュール登録() を呼ぶ。私はさらに、ボタンにマクロを登録し、メール受信の個別ウィンドウやメール全体を表示しているビュー両方でボタンがすぐ押せる状態にしています。

これもおすすめ 

作業効率技の、次のページもどうぞ

Outlook

 ソース

github上

Public Sub 選択メールのスケジュール登録()


    If TypeName(ActiveWindow) = "Explorer" Then
      SaveAppointmentFromMessage ActiveExplorer.Selection(1)
    Else
      SaveAppointmentFromMessage ActiveInspector.CurrentItem
    End If
    
    '    If objItem.MessageClass = "IPM.Note" Then
    'メールじゃないスケジュールのケースなど
End Sub

' メッセージから予定を作成する
Private Sub SaveAppointmentFromMessage(ByVal objMail As MailItem)
    Dim strBody As String
    Dim strSubject As String
    Dim strLocation As String
    Dim strDate As String
    Dim strStart As String
    Dim strEnd As String
    Dim i As Long
    Dim objAppt As AppointmentItem
        
    Dim re As RegExp
    Dim mc As MatchCollection
    
    Dim f As Boolean
    Dim sts As String
    Dim ste As String
    
            
    ' スケジュール管理ソフト以外からのメールは処理しない
    'If Not objMail.Subject Like "スケジュール登録のお知らせ*" Then
    '    Exit Sub
    'End If
    ' 本文を取得
    strBody = objMail.Body

    
    ' 本文から件名や場所などを取得
    strSubject = GetFieldReg(strBody, "件[  ]*名")
    strLocation = GetFieldReg(strBody, "場[  ]*所")
    
    If strSubject = "" Then
        strSubject = GetFieldReg(strBody, "議[  ]*題")
    End If
    If strSubject = "" Then
        strSubject = GetFieldReg(strBody, "アジェンダ")
    End If
    If strSubject = "" Then
        strSubject = GetFieldReg(strBody, "目[  ]*的")
    End If
    
    If strSubject = "" Then
        strSubject = objMail.Subject
    End If
    
    'MsgBox "1st get:" & strSubject & vbCrLf & "," & strLocation & "," & strDate
    '日時を処理 (マッチ個所 0:年/日付   1:開始時刻  ~ 2:終了時刻(あれば)   3:タイトルなど(あれば)
        Set re = New RegExp
        're.Pattern = "([0-9]+/[0-9]+[\(\)a-zA-Z月火水目金土日]+[  \t]*[0-9]+\:[0-9]+)"
        re.Pattern = "([0-90-9]*[  ]*[//年]?[  ]*[0-90-9]+[  ]*[//月][  ]*[0-90-9]+)[  ]*日?[  \t]*" _
        & "[\(\)()a-zA-Z月火水木金土日]*[  \t]*([0-90-9]+[::][0-90-9]+)" _
        & "[-ー―-~~  \t]*([0-90-9]+[::][0-90-9]+)*[  \t]*([^\n]*)"
        re.Global = True
        re.MultiLine = True
        
        'MsgBox ("hi!  1-3 " & Left(strBody, 120))
        Set mc = re.Execute(strBody)
        f = False
        
        If mc.Count = 0 Then
            f = True
            
            re.Pattern = "[[{【{「]?日[  ]*[程時付][]}】}」]?[  \t]*[::]?[  \t]*[^0-90-9]*" _
            & "([0-90-9]*[  ]*[//年]?[  ]*[0-90-9]+[  ]*[//月][  ]*[0-90-9]+)[  ]*日?[  \t]*" _
            & "[\(\)()a-zA-Z月火水木金土日]*[  \t]*([0-90-9]+[::時][0-90-9]+)?分?" _
            & "[-ー―-~~  \t]*([0-90-9]+[::][0-90-9]+)*[  \t]*([^\n]*)"
            Set mc = re.Execute(strBody)
            
        End If
        
        If mc.Count = 0 Then
            re.Pattern = "開[催始]日[  \t]*[::][  \t]*.+" _
            & "([0-90-9]*[  ]*[//年]?[  ]*[0-90-9]+[  ]*[//月][  ]*[0-90-9]+)[  ]*日?[  \t]*" _
            & "[\(\)()a-zA-Z月火水木金土日]*[  \t]*([0-90-9]+[::時][0-90-9]+)?分?" _
            & "[-ー―-~~  \t]*([0-90-9]+[::時][0-90-9]+)*分?[  \t]*([^\n]*)"
            Set mc = re.Execute(strBody)
        End If
        
        If mc.Count = 0 Then
            MsgBox "日付らしいものが見つかりません。"
            Exit Sub
        End If
        
        y = ""
        If Len(mc(0).SubMatches(0)) < 6 Then
            y = Year(objMail.ReceivedTime) & "/"
        End If
        y = y & Replace(StrConv(Replace(Replace(mc(0).SubMatches(0), "月", "/"), "年", "/"), vbNarrow), " ", "")
        
        sts = mc(0).SubMatches(1)
        ste = mc(0).SubMatches(2)
        stl = Trim(mc(0).SubMatches(3))
        
        If ste = "" And stl <> "" Then
            re.Pattern = "([0-90-9]+[::時][0-90-9]+)"
            Set mcsub = re.Execute(stl)
            If mcsub.Count <> 0 Then
                ste = mcsub(0).SubMatches(0)
                stl = ""
            End If
        End If
        sts = Replace(sts, "時", ":") '分の文字はない前提(上記までで処理)
        ste = Replace(ste, "時", ":")
        

        If strLocation = "" And stl <> "" And stl <> "" & Chr(13) Then
            strLocation = stl 'mc(0).SubMatches(3)
        End If
        
       
        If sts = "" Then 'Or f = True
            
            re.Pattern = "時?間?[  \t]*[::][  \t]*([0-90-9]+[::時][0-90-9]+)[-ー―-~~  \t]*([0-90-9]+[::時][0-90-9]+)*"
            Set mc = re.Execute(strBody)
            If mc.Count = 0 Then
                If sts <> "" Then
                    MsgBox "日時フォーマット失敗?" & sts & " , " & ste
                End If
                sts = ""
                ste = ""
            Else
                sts = mc(0).SubMatches(0)
                ste = mc(0).SubMatches(1)
            End If
            
            sts = Replace(sts, "時", ":")
            ste = Replace(ste, "時", ":")
            
            If sts = "" Then
                sts = "9:00"
            End If
            strStart = y & " " & sts
        Else
            strStart = y & " " & StrConv(sts, vbNarrow)
        End If


        If ste = "" Then
            strEnd = y & " " & StrConv(sts, vbNarrow)
        Else
            strEnd = y & " " & StrConv(ste, vbNarrow)
        End If


    'MsgBox ("hi2! " & strLocation & " " & strStart & "~" & strEnd)
    
   
    ' 取得した情報で予定アイテムを作成
    Set objAppt = Application.CreateItem(olAppointmentItem) '予定表でなければここの引数を変え適切に処理する
    objAppt.Subject = strSubject
    objAppt.Location = strLocation
    objAppt.Start = strStart
    objAppt.End = strEnd
    objAppt.Body = strBody
    
    'reminder
    objAppt.ReminderSet = True
    objAppt.ReminderMinutesBeforeStart = 15
    
    'objAppt.AllDayEvent = True
    'objAppt.Duration = 120
    
    objAppt.Save
    objAppt.Display

    MsgBox ("スケジュール登録しました。(^^)b" & vbCrLf & objAppt.Subject & " : " & strStart & "~")

End Sub
' 本文から特定の情報を取得する関数
Private Function GetFieldReg(strBody As String, strName As String)
    Dim re As RegExp
    Dim mc As MatchCollection
        
    Set re = New RegExp
    re.Pattern = strName & "[  \t]*[]::  】」}}][  \t]*(.+)"
    Set mc = re.Execute(strBody)

    If mc.Count = 0 Then
      GetFieldReg = ""
    Else
      GetFieldReg = mc(0).SubMatches(0)
    End If

End Function
Delicious にシェア
Digg にシェア
reddit にシェア
LinkedIn にシェア
LINEで送る
email this
Pocket

7,757 views.



コメントを残す

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