OutlookVBA メール検索

Outlookの標準機能の検索ってなんかイケてない（検索語句と無関係のものまで表示される）ので作ってみた

イメージ

灰色のTextBoxは未実装

残課題

• HTMLメールだとコードまみれで読めない
• とりあえず検索としてあるがBodyしか検索してないのでSubjectとかもカバーする?
• 詳細検索機能追加
• ユーザーフォームのプロパティのコード化

コード 標準モジュール

実行は「showUI」

Option Explicit

Type MailProperty
  obj As Object
  rcvTime As Date
  Sub As String
  from As String
  Bdy As String
  HTMLBdy As String
  t As String
  cc As String
  bcc As String
End Type
Public ml() As MailProperty
Public HitMail() As MailProperty

Sub showUI()
  メール検索結果表示.Show vbModeless
End Sub

Sub SearchMail_inArray(rc)
  rc = "*" & rc & "*"

  '全メールを取得
  Call GetMail_To_ml
  
  Dim k: k = 0
  
  '検索。ヒットするものだけ抜き取る
  Dim i
  For i = 0 To UBound(ml)
    Select Case True
      Case ml(i).Bdy Like rc:
        k = k + 1
        ReDim Preserve HitMail(k)
        HitMail(k) = ml(i)
      Case ml(i).Sub Like rc:
    End Select
  Next
  
End Sub

Sub GetMail_To_ml()
  Dim Ts As Double: Ts = 時間計測start
  
  Dim objSelect As Object
  Dim objMailItem As Object
  
  Set objSelect = ActiveExplorer.CurrentFolder.Items '.Selection
  
  Dim cnt: cnt = objSelect.Count
  Debug.Print cnt
  
  Dim obj As Object
  Dim i
  For i = 1 To 50 'cnt
    Set objMailItem = objSelect(i)
    ReDim Preserve ml(i)
    
    With objMailItem
'      Debug.Print i; .Subject
      
      Set ml(i).obj = objMailItem
      ml(i).rcvTime = .ReceivedTime
      ml(i).Sub = .Subject
      ml(i).Bdy = .Body
      ml(i).HTMLBdy = .HTMLBody
      ml(i).from = .SenderName
      ml(i).t = .to
      ml(i).cc = .cc
      ml(i).bcc = .bcc
    End With
    i = i + 1
  Next
  
  Call 時間計測end(Ts)
  
End Sub

コード 標準モジュール（時間計測用）

よく使うので別モジュールにしてます。

Option Explicit

Function 時間計測start()
  '開始時間取得
  時間計測start = Timer
End Function
Function 時間計測end(startTime As Double)
'  Application.ScreenUpdating = False
'  Dim startTime As Double
  Dim endTime As Double
  Dim processTime As Double
  Dim i As Long

  '終了時間取得
  endTime = Timer

  '処理時間表示
  processTime = endTime - startTime
  processTime = Round(processTime, 1)
  Debug.Print "処理時間：" & processTime & "[秒]"
'  Application.ScreenUpdating = True

End Function

コード ユーザーフォーム

オブジェクト名（左上から順に）

• TB_とりあえず
• BTN_GO
• BTN_CLOSE
• ListBox1
• TB_本文

メール検索結果表示

Option Explicit

Private Sub SetObjConfig(obj As Object, Top, Left, h, w)
  With obj
    .Top = Top
    .Left = Left
    .Height = h
    .Width = w
  End With
End Sub

Private Sub UserForm_Initialize()

  With ListBox1
    .ColumnCount = 3
    .ColumnWidths = "200;300;400"
    .BorderStyle = fmBorderStyleSingle
    .ListStyle = fmListStyleOption
  End With
  
  '複数行を許可
  TB_本文.MultiLine = True
  TB_本文.WordWrap = True
  
'  着色
'  Dim c0: c0 = 16777215
'  Me.BackColor = c0
  
  TB_とりあえず.SetFocus
End Sub

Private Sub BTN_GO_Click()
  Call リスト追加(KW:=TB_とりあえず.Text)
End Sub

Sub リスト追加(KW)
  On Error GoTo Err
  Call SearchMail_inArray(KW)
  
  '検索結果をリストボックス内に書き出し
  Dim i
    With ListBox1
      .Clear
      For i = 0 To UBound(HitMail) - 1
        .AddItem ""
        .List(i, 0) = HitMail(i).from
        .List(i, 1) = HitMail(i).Sub
        .List(i, 2) = Left(HitMail(i).Bdy, 50)
      Next
    End With
    
    Exit Sub
Err:
    Select Case Err.Number
      Case Is = 9:
        With ListBox1
          .AddItem ""
          .List(0, 0) = "検索結果なし"
        End With
    End Select
    
End Sub

Private Sub BTN_CLOSE_Click()
  Unload Me
End Sub


Private Sub ListBox1_Click()
On Error GoTo Err
  Dim n
  n = ListBox1.ListIndex
  TB_本文.Text = HitMail(n).Bdy
'  WebBrowser1.Navigate2 HitMail(n).HTMLBdy
    
  Exit Sub
Err:
    Select Case Err.Number
      Case Is = 9: Exit Sub
    End Select

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error GoTo Err
  Dim n
  n = ListBox1.ListIndex
  HitMail(n).obj.Display

  Exit Sub
Err:
    Select Case Err.Number
      Case Is = 9: Exit Sub
    End Select
End Sub