Ｋ２さんの雑記

2015-07-06(Mon) [長年日記]

■ [無線]電信の練習

ここのところ電信の練習ばかりしていて、電話での交信もさぼってしまっている。

受信は12文字/分くらいならなんとかすべての文字を書き取ることができるようになったが、これではまだまだ不十分。これ以上は、ペンを使わずに、頻出単語をそのままモールスで覚えてしまって、コールサインなど必要な部分だけペン書きする方法をとらないと速度は上がらなさそう。

送信練習もやっているが、16文字/分くらいならそこそこ打てるようになった。が、打ち間違え０の状態にはほとほと遠く、特に短点の数を時々間違えてしまう。１点少ないというのが一番多い。エレキーは、リズムは最初からうまく取れるのだが、短点連続の点数の制御が難しいと思う。

まだ1st交信をする自信はないので、もう少しSWLと送信練習を続けようと思う。

[ツッコミを入れる]

2015-07-16(Thu) [長年日記]

■ 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を待ち望んでいるのだが……（これは無理そうね）

[ツッコミを入れる]

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

本日のツッコミ(全1件) [ツッコミを入れる]

◆ (な) [trello に積みました(^^)]

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)２度同じマクロを実行する必要がある
       ' (3) 選択されたアイテムは、リストビュー上で表示
       ' される位置までスクロールはされていない
       Set objSel = ActiveExplorer.Selection(1)
       ActiveExplorer.RemoveFromSelection objSel
       ActiveExplorer.AddToSelection oMailItem
   End If
End Sub

まず、選択動作等は、フォルダの表示形式をスレッドにしているとうまくいかないようだ。

また、フォルダを表示してからすぐにコードを実行するとうまく動かないようだ。上記のコードは２回動作させてやっと選択される。

選択されたメールは、リストビュー上で見える位置までスクロールされない。

以上のように、まだまだ問題点を抱えている。

メール選択の代わりに、フィルターを使用する方法も試してみた。これも、上記のように２回実行する必要があるが、スレッド表示状態でも動作する。なお、動かした後はフィルタを解除しないと正常動作に戻らないので注意。

また、試行中にビュー設定がおかしくなる場合があるので、それについても要注意。その場合は、別のフォルダのビュー設定をコピーしてくれば元に戻る。

       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|

2002|09|10|11|12|