K2さんの雑記
2015-07-06(Mon) [長年日記]■ [無線]電信の練習ここのところ電信の練習ばかりしていて、電話での交信もさぼってしまっている。 受信は12文字/分くらいならなんとかすべての文字を書き取ることができるようになったが、これではまだまだ不十分。これ以上は、ペンを使わずに、頻出単語をそのままモールスで覚えてしまって、コールサインなど必要な部分だけペン書きする方法をとらないと速度は上がらなさそう。 送信練習もやっているが、16文字/分くらいならそこそこ打てるようになった。が、打ち間違え0の状態にはほとほと遠く、特に短点の数を時々間違えてしまう。1点少ないというのが一番多い。エレキーは、リズムは最初からうまく取れるのだが、短点連続の点数の制御が難しいと思う。 まだ1st交信をする自信はないので、もう少しSWLと送信練習を続けようと思う。 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を待ち望んでいるのだが……(これは無理そうね) 2015-07-17(Fri) [長年日記]■ Outlookで指定したMessage-IDのメールを検索して表示するマクロ(挑戦中)題目の通り、まずはマクロでMessage-ID検索を作ろうとした。 Message-IDに対応するメールを検索し、存在するフォルダを表示するところまではできたのだが、そのメールを選択状態にするところではまった。 Webを検索して情報を調べているのだが、どうも誰もできていなさそう。そんな簡単そうなことができないなんて、どういう事なんだろう。 P.S. naoさん、助けてください! Public Sub SearchEmailTPZ() Dim oMailItem, oCurrentSelectedItem As MailItem Dim oFolder As Folder, intWait As Integer '以下の""内に、該当メールのMessage-IDを書く Set oMailItem = SearchEmailByMessageID _ ("<1111111111111@prod.outlook.com>") If Not oMailItem Is Nothing Then Set oFolder = oMailItem.Parent '↓これでフォルダを開くところまではOK Set ActiveExplorer.CurrentFolder = oFolder '↓ここができない。書いてあるコードでは動作しない ActiveExplorer.ClearSelection ActiveExplorer.AddToSelection oMailItem End If End Sub 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 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 2015-07-21(Tue) [長年日記]■ Outlookで指定したMessage-IDのメールを検索して表示するマクロ(2)ちょっとだけ進んだ。 Public Sub SearchEmailTPZ() Dim oMailItem, oCurrentSelectedItem As MailItem Dim oFolder As Folder Dim sFilter, sMessageID As String Dim objSel '以下の""内に、該当メールのMessage-IDを書く sMessageID = "<1111111111111111@xxx.xxx.xxx>" Set oMailItem = SearchEmailByMessageID(sMessageID) If Not oMailItem Is Nothing Then Set oFolder = oMailItem.Parent Set ActiveExplorer.CurrentFolder = oFolder ' 以下のコードは不安定だが一応動作するようだ ' ただし、(1)フォルダがスレッド状態でないこと ' (2)2度同じマクロを実行する必要がある ' (3) 選択されたアイテムは、リストビュー上で表示 ' される位置までスクロールはされていない Set objSel = ActiveExplorer.Selection(1) ActiveExplorer.RemoveFromSelection objSel ActiveExplorer.AddToSelection oMailItem End If End Sub まず、選択動作等は、フォルダの表示形式をスレッドにしているとうまくいかないようだ。 また、フォルダを表示してからすぐにコードを実行するとうまく動かないようだ。上記のコードは2回動作させてやっと選択される。 選択されたメールは、リストビュー上で見える位置までスクロールされない。 以上のように、まだまだ問題点を抱えている。 メール選択の代わりに、フィルターを使用する方法も試してみた。これも、上記のように2回実行する必要があるが、スレッド表示状態でも動作する。なお、動かした後はフィルタを解除しないと正常動作に戻らないので注意。 また、試行中にビュー設定がおかしくなる場合があるので、それについても要注意。その場合は、別のフォルダのビュー設定をコピーしてくれば元に戻る。 sFilter = _ """http://schemas.microsoft.com/mapi/proptag/0x1035001E"" = " _ & " '" & sMessageID & "'" ActiveExplorer.CurrentView.filter = sFilter ActiveExplorer.CurrentView.Save ActiveExplorer.CurrentView.Apply 2015-07-23(Thu) [長年日記]■ Outlookで指定したMessage-IDのメールを検索して表示するマクロ(3)本日も少しだけ進んだ。 MailItemをCurrentFolder変更したイベントで選択しようとしてもどうしてもできない。SleepやWait等を入れても、そのイベントが終了してから、Folder変更後そのフォルダの内容がすべて表示される。 DelphiのProcessMessages関数に当たるDoEventsを入れても動作は同じだった。 いったんイベントを抜けてから、遅延実行をさせるためには、タイマーイベントを使うか、他のハンドラを使う手があるが、VBAにはタイマーコントロールはないとのこと。 Explorer_FolderSwitchイベントを使うと直感的にはいけそうな気がしたが、結論から言うと、Explorer_FolderSwitchイベントハンドラの中でDoEventsを実行すると、その後MailItemの選択状態変更が効くようになるようだ。 ただし、スレッド表示状態ではだめ。また選択できてもスクロールしてそのメールが表示されるようにはならない。 ちょっとだけ光明は射してきたが、実用域まではまだまだだ…… 2015-07-27(Mon) [長年日記]■ Outlook2013で指定したMessage-IDのメールを検索して表示するマクロ(一応完了)該当フォルダに飛んでからそのメールを選択する方法は、いろいろ試したがなかなかうまくいかない。 結局、そのメッセージIDのメールだけを選択するフィルタをかけることにした。スレッド表示でもフィルタはかかるし、そのスレッドを構成する他のメールも見えるようなので、一応実用レベルかと思う。 作業が終わったら、フィルタを解除する必要があるが、それを一発で行うマクロも書いた。 SearchEmailTPZ() 実行するとMessageId入力ダイアログが出る。 OKを押すと、該当フォルダに飛び、そのメールだけが表示される。 受信トレイ(InputBox)配下に検索対象フォルダがある必要がある) FilterReset() 現在のフィルタをリセットする。 '=========================================================== ' グローバル変数定義 '=========================================================== Public WithEvents myOlExp As Outlook.Explorer Public ObjFoundMailItemTPZ As MailItem Dim StrMessageID As String '=========================================================== ' システムイベント '=========================================================== '----------------------------------------------------------- ' 起動時イベント '----------------------------------------------------------- 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 '=========================================================== ' 現在のフィルタをリセットする '=========================================================== 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 = 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 さて、次は、TaskPrizeからこの関数を自動的に呼び出してMessageIDを渡す方法を考えたい。そんな方法はあるのだろうか。 2015-07-30(Thu) [長年日記]■ Outlook2013で、メール作成時にエディタで本文を編集するマクロOutlookは、メール閲覧・作成に関しては、等幅フォントをサポートしているようで、この点は何とか耐えうる。 しかしながら、メール作成時に自動改行的な機能は持っていないので、Becky!に慣れていた私としては、手動で改行を入れていたが、我慢ならなくなった。 で、本文をテンポラリファイルに出力し、外部エディタを起動・編集、外部エディタを終了したら、Outlookの編集画面に編集されたテンポラリファイルを読み込むというマクロを作成した。一応動いているようだ。 '=========================================================== ' その他定義 '=========================================================== Option Explicit Private Declare Function OpenProcess Lib "kernel32" _ (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) As Long Private Declare Function GetExitCodeProcess Lib "kernel32" _ (ByVal hProcess As Long, lpExitCode As Long) As Long Private Declare Function CloseHandle Lib "kernel32" _ (ByVal hObject As Long) 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 Loop While (EndCode = STILL_ACTIVE) 'ハンドルを閉じる EndRet = CloseHandle(hProcess) End Sub '=========================================================== ' 現在のインスペクターの本文をエディタで編集し、 ' インスペクターで編集文書を読み込む ' 2015/7/30 by K2 '=========================================================== Public Sub InspectorBodyEdit() Dim FileName As String Dim EditorFileName As String Dim S, SBuf As String Dim Ret1 As Long '適当なテンポラリファイル名 FileName = "C:\OutlookMailTemp.txt" '開くエディタ名 EditorFileName = "C:\Tools\K2Editor\K2Editor.exe" Open FileName For Output As #1 Print #1, ActiveInspector.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 'インスペクターに本文を入力 ActiveInspector.CurrentItem.Body = S End If 'インスペクターにフォーカスを当てる ActiveInspector.Activate End Sub 1965|09|
|
//
自己紹介
自己紹介
広告
計るだけダイエット
つっこみリスト
TrackBacks
日記仲間
な/
す/
ひ/
最近の日記
|
◆ (な) [trello に積みました(^^)]