Ｋ２さんの雑記

■ Outlook強制化

私の部署の一斉切り替えがあり、昨日からOutlookでのメール作業が強制化されました。

いや一種の業務テロだぜ、これは。

生産性が1/2くらいに落ちる。

後、どうも紙の本を読んでいるところから、PCで本を読むようになった初期の頃の感覚に近い。メール本文が頭に入ってこない。

まぁ慣れるしかないのです。

さて、ここにTaskPrizeでの作業をどう割り込ましていこうか。まずは、OutlookからTaskPrizeへメールを飛ばせるようにしたい。

■ OutlookからTaskPrizeへメールを飛ばすマクロ

ちょっとまだ作り込みが甘いけど、とりあえず動きました。

所要時間４時間くらいか。意外と簡単にできました。

TaskPrizeには、MBOX形式のテキストファイルを起動オプションで指定してやると取り込めるので、Outlookで選択されているメールを、MBOX形式でファイルに落として、TaskPrizeを起動するというマクロを書けばOK。

なのだが、ヘッダ付きのメールを得るのが一苦労。Outlook2007未満では、マクロではできなかったようなので、まぁできることに感謝したい。

取得したヘッダは、改行付きの連続文字列で取得できる。これをプロパティごとに分解しなければならない。

StringListクラスがVBAにあると簡単なのだが、どうもないらしい。仕方がないので、改行コードを検索することにした。まぁこれもなんとか動いているようだ。

ヘッダ付きのテキストに落とすだけのマクロも、なかなか例としては見つけられなかった。下記のマクロは、ちょっと改造すればその用途にも十分使えるし、ヘッダを表示するマクロなんてのもすぐにできるだろう。

   '===========================================================
   '  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 = "C:\TPZ.txt"
       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 "E:\Project\TaskPrize2\TskPrize.exe -ic:\TPZ.txt", 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 & " | Message-ID: " & GetHeaderText(sHeader, "Message-ID: ") & vbCr & vbLf
       S = S & "------------------------------------------------------------"
       GetTPZMailPrescript = S
   End Function

   '-----------------------------------------------------------
   '  指定されたヘッダー文字列を得る
   '    複数行にわたるヘッダには対応していないので注意
   '-----------------------------------------------------------
   Private Function GetHeaderText(Header As String, Prop As String) As String
       Dim I As Variant, Length As Integer
       I = InStr(1, Header, Prop, vbTextCompare)
       If I > 0 Then
           I = I + Len(Prop)
           Length = InStr(I, Header, vbCrLf, vbTextCompare)
           If Length > 0 Then
             Length = Length - I
           Else
             Length = Len(Header) - I + 1
           End If
           GetHeaderText = Mid(Header, I, Length)
       Else
           GetHeaderText = ""
       End If
   End Function

しかし、やっぱりBASICはきらい。この文法はどうも私には合わない。

VBの関数で、()をつけるとエラーになるのとならないのは、どういう違いがあるのだろう。SubとFunctionの違いでもなさそう……

P.S.(2018/7/26) 最近、突然仕様が変わったのか、Outlookメールのヘッダで、Message-ID:の行が複数行仕様になってしまった。そのため、上記のGetHeaderTextではうまく動かなくなった。

GetHeaderTextの修正版を作成したので、記入しておきます。

   '-----------------------------------------------------------
   '  指定されたヘッダー文字列を得る
   '-----------------------------------------------------------
   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)
       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
       Else
           GetHeaderText = ""
       End If
   End Function

■ 新型iPod touch

何そのテロ的新製品。

CPUとカメラが変わっただけの、第６世代？　5Sなのか？

こないだ電池交換（という名の新品交換）したところだけど、32GBを速攻ぽちってしまいました。土曜日には届くでしょう。

GPSを待ち望んでいるのだが……（これは無理そうね）