某所から需要があったので、以前2015年頃に作ったOutlookとTaskPrizeの連携用Outlookマクロ公開します。
マクロの中に直接TaskPrizeのフルパス、テンポラリファイルやエディタについてファイル名を記入してしまっているので、それは自分の環境に合わせて直す必要あります。
OutlookのメインウィンドウのクイックアクセスツールバーにPublic関数を登録して使ってください。TPZSendMail、SearchEMailTPZ、FilterReset、TPZShowMailの4関数があります。
TPZSendMailで、TaskPrizeに表示しているメールを飛ばします。
SearchEMailTPZを起動すると、MessageIdを入力するダイアログが開くので、<>で囲まれたMessageIdを<>付きで入力すれば該当メールにジャンプします。
該当メールにジャンプの機能は、Outlookのフィルタの機能を使っているので、上記のジャンプが終わったらFilterResetを呼び出してOutlookのフィルタをリセットする必要があります。これを忘れると他のメールが表示されなくなるので気を付けて。
追記(2022/7/1)：またこの機能は一度では動作しない場合が多く、同じ検索を二回連続で行うとうまくいくことが多いです。この現象はマクロを書いた当時から再現していますが、修正できていません。
TPZShowMailは、TaskPrizeにメールを飛ばさず、指定されたエディタで表示します。ヘッダ付きで表示されるので、ヘッダを確認したかったり、TaskPrize向けのプリスクリプトだけクリップボードにコピーしたい場合などに使います。
Outlookのエディタウィンドウのクイックアクセスツールバーには、同じくPublic関数のInspectorBodyEditを登録すると、外部エディタ編集ができるようになります。起動するとエディタウィンドウの内容が指定した外部エディタで開きます。外部エディタで編集後、セーブして外部エディタを閉じると、その内容をエディタウィンドウが読み込みます。外部エディタ起動中はOutlook動作は一部おかしくなりますので、外部エディタを開きっぱなしで忘れないようにする必要があります（たまにやります。Outlookの動作がおかしかったら、どこかに外部エディタが隠れていないか確認してください）。
また、外部エディタ編集を行う際には、かならず書式を「テキスト」にしてください。HTMLメールは外部エディタで編集できません。間違えてHTMLメールを外部エディタで編集してしまうと、外部エディタを閉じたときに、Outlookのエディタ上で内容が一部文字化けしてしまいます。直すことができませんので、その場合は再びメールを作成し直す必要があります。注意が必要です。
なお、Outlookのマクロを実行するためには、証明書登録とか必要だったと思うので、それはOutlookのマクロを解説したページで調べてください。
Good luck!
追記：すのこさんの指摘により、64bit版で動作するように変更しました。修正内容はリンク先の記事を参照してください。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 |
'=========================================================== ' グローバル変数定義 '=========================================================== Public myOlExp As Outlook.Explorer Public ObjFoundMailItemTPZ As MailItem Dim StrMessageID As String '=========================================================== ' その他定義 '=========================================================== Option Explicit '既存のプロセスオブジェクトのハンドルを取得 Private Declare PtrSafe Function OpenProcess Lib "kernel32" _ (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) As Long '指定のプロセスの終了コードを取得 Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _ (ByVal hProcess As Long, lpExitCode As Long) As Long '開かれているオブジェクトのハンドルを解放する Private Declare PtrSafe Function CloseHandle Lib "kernel32" _ (ByVal hObject As Long) As Long Private Declare PtrSafe Sub Sleep Lib "kernel32" _ (ByVal dwMilliseconds As Long) Private Const PROCESS_QUERY_INFORMATION = &H400& Private Const STILL_ACTIVE = &H103& '----------------------------------------------------------- ' ProcessIDのプロセスが終了するまで待つ '----------------------------------------------------------- Private Sub ShellEnd(ProcessID As Long, DoProcessMessages As Boolean) Dim hProcess As Long Dim EndCode As Long Dim EndRet As Long 'ハンドルを取得する hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 0, ProcessID) '終わるまで待つ Do EndRet = GetExitCodeProcess(hProcess, EndCode) If DoProcessMessages Then DoEvents End If Sleep (100) Loop While (EndCode = STILL_ACTIVE) 'ハンドルを閉じる EndRet = CloseHandle(hProcess) End Sub '=========================================================== ' システムイベント '=========================================================== '----------------------------------------------------------- ' 起動時イベント '----------------------------------------------------------- Private Sub Application_Startup() Set myOlExp = Application.ActiveExplorer '---- SearchEmailTPZ()より Set ObjFoundMailItemTPZ = Nothing End Sub '----------------------------------------------------------- ' 現在のエクスプローラのフォルダー変更イベント '----------------------------------------------------------- Private Sub myOlExp_FolderSwitch() Dim sFilter As String '---- SearchEmailTPZ()より If Not ObjFoundMailItemTPZ Is Nothing Then DoEvents 'メッセージIDのフィルタをかける sFilter = _ """http://schemas.microsoft.com/mapi/proptag/0x1035001E"" = " _ & " '" & StrMessageID & "'" ActiveExplorer.CurrentView.Filter = sFilter ActiveExplorer.CurrentView.Save ActiveExplorer.CurrentView.Apply Set ObjFoundMailItemTPZ = Nothing End If End Sub '=========================================================== ' 現在のインスペクターの本文をエディタで編集し、 ' インスペクターで編集文書を読み込む ' 2015/7/30 by K2 '=========================================================== Public Sub InspectorBodyEdit() subInspectorBodyEdit Application.ActiveInspector End Sub Private Sub subInspectorBodyEdit(Inspector As Inspector) Dim FileName As String Dim EditorFileName As String Dim S, SBuf As String Dim Ret1 As Long '適当なテンポラリファイル名 FileName = "E:\Tmp\OutlookMailTemp.mxt" '開くエディタ名 EditorFileName = "C:\Tools\K2Editor\K2Editor.exe /j1 /x1" Open FileName For Output As #1 Print #1, Inspector.CurrentItem.Body Close #1 'エディタ起動 Ret1 = Shell(EditorFileName & " " & FileName, 1) 'エディタが終了するまで待機 ShellEnd Ret1, True S = "" If Dir(FileName) <> "" Then ' テンポラリファイルを開いてテキストを得る Open FileName For Input As #1 Do Until EOF(1) Line Input #1, SBuf S = S & SBuf & vbCr & vbLf Loop Close #1 'インスペクターに本文を入力 Inspector.CurrentItem.Body = S End If 'インスペクターにフォーカスを当てる Inspector.Activate End Sub '=========================================================== ' TaskPrizeへメールを送る ' 2015/7/16 by K2 '=========================================================== Public Sub TPZSendMail() Dim myOLobj As Selection, M As MailItem, PA As PropertyAccessor Dim I As Integer Dim FileName As String I = 0 'テンポラリファイルはとりあえず決め打ち FileName = "E:\Tmp\TPZ.mxt" Set myOLobj = Application.ActiveExplorer.Selection For Each M In myOLobj If I <> 0 Then '複数のメールが選択されている場合はピリオドだけの行を出力 Open FileName For Append As #1 Print #1, "." Close #1 End If MailSaveForTPZ M, FileName, I I = I + 1 Next '以下はTaskPrizeのインストールフォルダのパスに書き換える必要有り Shell "C:\Tools\TaskPrize2\TskPrize.exe -ie:\Tmp\TPZ.mxt", vbNormalFocus End Sub '=========================================================== ' メール本文をエディタで表示する ' 2015/8/18 by K2 '=========================================================== Public Sub TPZShowMail() Dim myOLobj As Selection, M As MailItem, PA As PropertyAccessor Dim I As Integer Dim FileName As String Dim EditorFileName As String I = 0 'テンポラリファイルはとりあえず決め打ち FileName = "E:\Tmp\TPZ.mxt" Set myOLobj = Application.ActiveExplorer.Selection For Each M In myOLobj If I <> 0 Then '複数のメールが選択されている場合はピリオドだけの行を出力 Open FileName For Append As #1 Print #1, "." Close #1 End If MailSaveForTPZ M, FileName, I I = I + 1 Next '以下はTaskPrizeのインストールフォルダのパスに書き換える必要有り '開くエディタ名 EditorFileName = "C:\Tools\K2Editor\K2Editor.exe -j70 -x1" Shell EditorFileName & " E:\Tmp\TPZ.mxt", vbNormalFocus End Sub '----------------------------------------------------------- ' メール一通をテンポラリファイルに出力 '----------------------------------------------------------- Private Sub MailSaveForTPZ(oMail As MailItem, FileName As String, Mode As Integer) Dim Header As String Dim PropName As String Dim oPA As PropertyAccessor Dim S As String 'PR_TRANSPORT_MESSAGE_HEADERS PropName = "http://schemas.microsoft.com/mapi/proptag/0x007D001E" 'Obtain an instance of PropertyAccessor class Set oPA = oMail.PropertyAccessor 'Call GetProperty Header = oPA.GetProperty(PropName) If Mode = 0 Then Open FileName For Output As #1 Else Open FileName For Append As #1 End If Print #1, Header S = GetTPZMailPrescript(oMail, Header) Print #1, S Print #1, oMail.Body Close #1 End Sub '----------------------------------------------------------- ' TPZへ送るメールの先頭部分の文字列を得る '----------------------------------------------------------- Private Function GetTPZMailPrescript(oMail As MailItem, sHeader As String) As String Dim S As String S = "------------------------------------------------------------" & vbCr & vbLf S = S & " | Date : " & GetHeaderText(sHeader, "Date:") & vbCr & vbLf S = S & " | From : " & oMail.SenderName & vbCr & vbLf S = S & " | Subject : " & oMail.Subject & vbCr & vbLf S = S & GetHeaderText(sHeader, "Message-ID:") & vbCr & vbLf S = S & "------------------------------------------------------------" GetTPZMailPrescript = S End Function '----------------------------------------------------------- ' 指定されたヘッダー文字列を得る ' 行先頭を検索、一行内Message-ID対応 '----------------------------------------------------------- Private Function GetHeaderText(Header As String, Prop As String) As String Dim I As Variant, Length As Integer Dim nextLineIndex As Integer I = InStr(1, Header, Prop, vbTextCompare) Do While I > 2 And Mid(Header, I - 2, 2) <> vbCrLf I = InStr(I + 1, Header, Prop, vbTextCompare) Loop If I > 0 Then I = I + Len(Prop) Length = InStr(I, Header, vbCrLf, vbTextCompare) If Length > 0 Then nextLineIndex = Length + 2 Length = Length - I Else nextLineIndex = 0 Length = Len(Header) - I + 1 End If GetHeaderText = LTrim(Mid(Header, I, Length)) 'ヘッダ直前のスペースは削除する ' 次の行から、行頭がホワイトスペースでない行まで、行を連結する Do While nextLineIndex > 0 And (Mid(Header, nextLineIndex, 1) = " " Or Mid(Header, nextLineIndex, 1) = vbTab) I = nextLineIndex Length = InStr(I, Header, vbCrLf, vbTextCompare) If Length > 0 Then nextLineIndex = Length + 2 Length = Length - I Else nextLineIndex = 0 Length = Len(Header) - I + 1 End If GetHeaderText = GetHeaderText & Mid(Header, I, Length) Loop GetHeaderText = Trim(GetHeaderText) Else GetHeaderText = "" End If End Function '=========================================================== ' 現在のフィルタをリセットする '=========================================================== Public Sub FilterReset() ActiveExplorer.CurrentView.Filter = "" ActiveExplorer.CurrentView.Save ActiveExplorer.CurrentView.Apply End Sub '=========================================================== ' メッセージIDのメールを検索してフォルダに移動 ' その後、FolderSwitchイベントでそのメッセージIDのメール ' のみ表示するフィルタをかける ' (myOlExp_FolderSwitch()で遅延実行) '=========================================================== Public Sub SearchEmailTPZ() Dim oCurrentSelectedItem As MailItem Dim oFolder As Folder, intWait As Integer Dim sFilter As String Dim objSel StrMessageID = Trim(InputBox(Prompt:="MessageId検索", _ Title:="MessageId検索")) Set ObjFoundMailItemTPZ = SearchEmailByMessageID(StrMessageID) If Not ObjFoundMailItemTPZ Is Nothing Then Set oFolder = ObjFoundMailItemTPZ.Parent If ActiveExplorer.CurrentFolder <> oFolder Then Set ActiveExplorer.CurrentFolder = oFolder Else myOlExp_FolderSwitch End If End If End Sub '----------------------------------------------------------- ' メッセージIDでメールを検索 '----------------------------------------------------------- Private Function SearchEmailByMessageID(MessageID As String) As MailItem Dim oFolder As Folder Dim sQuery As String sQuery = _ "@SQL=""http://schemas.microsoft.com/mapi/proptag/0x1035001E"" = " _ & " '" & MessageID & "'" '受信トレイフォルダを得る ' （検索フォルダは受信トレイのサブフォルダ） Set oFolder = ActiveExplorer.Session.GetDefaultFolder(6) Set SearchEmailByMessageID = SearchEmailByQuery(sQuery, oFolder) End Function '----------------------------------------------------------- ' メッセージIDでメールを検索(再起関数) '----------------------------------------------------------- Private Function SearchEmailByQuery(oQuery As String, _ oFolder As Folder) As MailItem Dim oFoundMail As MailItem, loFolder As Folder Set oFoundMail = oFolder.Items.Find(oQuery) If oFoundMail Is Nothing Then For Each loFolder In oFolder.Folders Set oFoundMail = SearchEmailByQuery(oQuery, loFolder) If Not oFoundMail Is Nothing Then Exit For End If Next End If Set SearchEmailByQuery = oFoundMail End Function |
コメント
すのこです。
自分の日記(tDiary)が動いていないので、ここで質問です。
このoutlookマクロ、いつからかメッセージID検索ができないかんじなのですが、Ｋ２さんのところはいかがでしょう？
office系は強制的にアップロードされているもので、いつからなのかわわからないのですが、検索のためにと思って各種控えていたメッセージIDで検索してくれません。
マクロがエラーになれば追えるのですが、エラーにならず何もしないで終了します。
なんとなくなんですが、フィルタが有効になっていないような気がします。
Microsoft® Outlook® for Microsoft 365 MSO (バージョン 2205 ビルド 16.0.15225.20278) 64 ビット
正直、かなり辛い(^^;)
—-
coreserverのシステムバージョンアップに伴い、古いrubyのサポートがなくなってしまい、困っている状況です(^^;) tDiaryはバージョンアップすればいいんでしょうが、家計簿のMoboが。。。ruby1.8.7 の野良ビルドにチャレンジしたのですがうまくいっていない。情けない状況です。
すのこです。
Ｋ２さん、ごめんなさい。私の勘違いだったようです。
検索を行うときのフォルダによって、１回では検索されないようですね。
検索するメールが存在するフォルダで行った場合にはきちんと１回の検索でヒットしますが、そうでない場合、１回目の検索では該当するフォルダに移動します。そして、もう一度同じidで検索すると、きちんと該当メールがヒットします。
この辺の挙動がいまいち一定でないのですが、これから続けて検索を行うようにします。
なんとなくoutlookの挙動が変化している感じがします。outlook よくわからないですね。いつのまにかフィルターの色替えが変わっていたりと難儀していますが、まぁ、スレッド操作以外はおおむね使えるようになりました。
スレッドを任意に操作できると情報管理がもっと楽になるんですが。。。
というか、もはや、メールのスレッドを利用している人はかなり少数派になっているようです。
すのこさん。
この辺の挙動安定していなくて、ご指摘の通り２回検索しないと機能しないというのはこちらでもそうです。マクロを書いた当初から現象はあって、Outlookの調子によるようですが、一発で検索できないのが現状です。
私はもう普段使いで２回検索がデフォルトになっているので、ご注意するのを忘れていました。
１年ほど前PCを新調してから、ちょっとの間は一発検索できていて調子よかったのですが、いつの間にかまた２回検索しないとヒットしないようになってしまいました。
このMessageID検索機能を搭載するのもかなり難儀しまして、該当のメールにフォーカスを当てたいだけなのですが、いろいろと苦肉の策で実現しています（と記憶しています）。なのでスレッドのフィルタリングなんて手法になっています。Outlookはマクロが使えて便利なのですが、挙動が不審なところも多いので、いろいろと難しいです。
すのこさん
Rubyのバージョン取り残され状態つらいですよね。
TaskPrizeのRubyマクロ自体が1.8までしか対応していないので、ファイルセットは必ず残してPCのバージョンアップをしています。
最近こちらも書けていませんが、WordPressにしてから、バージョンアップ等が楽で（システムでほぼ対応されていて、メールが来たらボタンを押しに来るくらいで、後は何も気にしなくてよい）、アップデートだけはちゃんとついて行けています。書きたいネタはいくつかあるのですが、ちょっと気分が乗らない（Twitterでつぶやいてしまって、吐き出し欲望が解消されてしまっていて……）。
すのこさんもWordPressはいかがですか？
すのこです。
メッセージID検索は、2回実行するのがデフォルト(^^;)で安心しました。
WordPressかぁ。coreserverは標準にあるんだよなぁ。どうしよう。
って、心と時間の余裕がなく、サーバーをいじっていない。
なんとかしないと、自分自身に備忘録がどんどんなくなってゆく。
家計簿は死活問題だったので、xrea で復活させました。サポートに聞くと、ruby1.8をいつまでサポートするかわからないとの事。さっさと家計簿も移そうかなぁ。
LINEは娘に強引に登録されたけど、TwitterはいまだにIDを持っていないという(^^;)ロートル人間が済んでゆく場所がなくなってゆくのは、なんだかなぁ。一旦構築したものが使えなくなるというのは、人類の大きな損失だと思うぞ。
tDiaryは、「最低でも四半世紀は日記を書き続けられるシステムであり続ける」の宣言通り長命ですが、バージョンアップが難しく（という印象があり）、こちらがついて行けなかったという思いが強いです。私はSAKURAサーバを使っていますが、古いRubyがどこまでサポートされるかわからないので、旧日記もいつまで参照できるか……
WordPressは導入も楽ですし、システムバージョンアップも非常に考えられていて、自動的にバージョンアップされてメール通知が来るだけ。プラグインやスタイルファイルは自分でバージョンアップしますが、ちょんちょんとマーキングしてボタンを一つ押すだけ。最初にデザインの調整さえしてしまえば、ほぼメンテナンスフリーです。
Twitterは結構楽しいですよ。私は絡む人はほとんどいませんが、人の意見を流し読みしながら、短文でつぶやくのは、tDiaryでやってた雑記に近く、表現欲はTwitterで発散している感じです。
始めたときはぜひ教えてください。