K2さんの雑記
2015-07-16(Thu) [長年日記]■ Outlook強制化私の部署の一斉切り替えがあり、昨日からOutlookでのメール作業が強制化されました。 いや一種の業務テロだぜ、これは。 生産性が1/2くらいに落ちる。 後、どうも紙の本を読んでいるところから、PCで本を読むようになった初期の頃の感覚に近い。メール本文が頭に入ってこない。 まぁ慣れるしかないのです。 さて、ここにTaskPrizeでの作業をどう割り込ましていこうか。まずは、OutlookからTaskPrizeへメールを飛ばせるようにしたい。 ■ OutlookからTaskPrizeへメールを飛ばすマクロちょっとまだ作り込みが甘いけど、とりあえず動きました。 所要時間4時間くらいか。意外と簡単にできました。 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とカメラが変わっただけの、第6世代? 5Sなのか? こないだ電池交換(という名の新品交換)したところだけど、32GBを速攻ぽちってしまいました。土曜日には届くでしょう。 GPSを待ち望んでいるのだが……(これは無理そうね) 1965|09|
|
//
自己紹介
自己紹介
広告
計るだけダイエット
つっこみリスト
TrackBacks
日記仲間
な/
す/
ひ/
最近の日記
|