【Accessをメール検索GUIとして使う03】受信/送信箱チェックボックス追加、ListBox選択アイテムの詳細表示を追加、検索条件クリアボタンを追加


https://qiita.com/taleau/items/29b56b1ba2afb893fa4e

フォームをもう少し拡張しました。いったん完成とします。

- 受信/送信箱チェックボックス追加
- ListBox選択アイテムの詳細表示を追加
- 検索条件クリアボタンを追加

緑色のものは前回と同じ。
オレンジ色のものが追加分。

色や立体表示はお好みで

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/281933/e6c9167a-f6c3-cffd-94c3-dc72894420a5.png)

## 説明

### 受信/送信箱チェックボックス追加
受信箱か送信箱かで分けたいという声があったので追加した。
チェックの入っている箱のアイテムだけが検索対象になる。

チェックの入ったフォルダ番号をSQL構文の`IN`構文に配列で入れるだけなのでこれも超簡単。
``` vb
strSQL = strSQL & "AND フォルダ IN (" & 対象フォルダ & ") "
```

実際に値が入るとこんな感じになる
`AND フォルダ IN ('6') `
`AND フォルダ IN ('5', '6') `


### ListBox選択アイテムの詳細表示を追加
ListBoxをダブルクリックすればOutlookで開くので詳細表示はいいやと思ってたけどやっぱり追加しました。

その中で端的には2通り思いついたのですが、それぞれメリット/デメリットがあるので好き好きで。

- ListBoxの`Column`で取り出すと軽いけど文字数制限がかかります。
- SQLで元のテーブルを参照しに行くと文字数制限はなくなるけど少し重くなります。

まあ詳細見たければOutlookで開いてみれば良いので、今回は軽さ優先でSQL方式は不採用としました。

### 検索条件クリアボタンを追加
各TextBox更新後イベントに都度捕まってしまうと検索条件の刷新にストレスを感じたので、検索用の全TextBoxをクリアできるようにした。

## コード
送信/受信箱のフィルタ列を追加しました。

### PowerShell
``` powershell
# csv出力先フォルダパスを設定してください Accessのメール検索ツールと同じフォルダ推奨
$path = "C:\Users\●●●\Access\olメール検索ツール\"


# Outlookのフォルダからメール一覧を作成、CSVに吐き出す

# 参考（Outlook取得）：https://www.itlab51.com/?p=6171
# 参考（CSV出力）：https://use-computer.net/powershell/powershell-course-5
# 参考（列挙型）：https://docs.microsoft.com/ja-jp/powershell/module/microsoft.powershell.core/about/about_enum?view=powershell-7.2


$oOutlook = New-Object -ComObject Outlook.Application
$oNamespace = $oOutlook.GetNamespace("MAPI")


# フォルダIndexの配列を作成
$arr_oFolders = @(5,6)
#$olFolderInbox = 6 #受信トレイ
#$olFolderSentMail = 5 #送信済みトレイ

# ループ回数の上限を設定（CSVに書き出すメール数）
$LimLoopCnt=10000

# 取得する文字数に制限をかける
$LimLenStr=10000                

# 変数の初期化
$CsvData = @()
$rr=0
 
# $ary_namesの要素を 1 つずつ $oFolder に格納してループする
for($fld = 0; $fld -lt $arr_oFolders.Count; $fld++){
    $oFolder = $oNamespace.GetDefaultFolder($arr_oFolders[$fld])

    # $oFolder内の全アイテムを巡回して1レコードずつCSV出力用の変数に格納していく
    foreach($oItem in $oFolder.Items){
            # 取得する文字数に制限をかける（文字数が多すぎるとセルをはみ出してテーブル構造が崩れるため）
            $Str = $oItem.Body
            $LenStr = ($oItem.Body).Length
            if ( $LenStr -gt $LimLenStr)
                {$Str = $Str.Substring(0,$LimLenStr)}
            
            # 添付ファイルリストを取得
            $attList=""
            foreach($att in $oItem.Attachments){
                $attList += ";" + $att.FileName
            }

            # 1レコードずつCSV用の変数につぎ足していく
            $CsvData += [PSCustomObject]@{
                No = $rr + 1 # 0始まりのため出力は1始まりにする
                フォルダ = $arr_oFolders[$fld]
                件名 = $oItem.Subject
                本文 = $Str.Replace("`r`n","") #改行殺し
                受信日時 = $oItem.ReceivedTime
                受信者名  =$oItem.To #ReceivedByNameだと自分以外が空白になる
                送信者名  =$oItem.SenderName
                CC = $oItem.CC
                添付ファイル = $attList
                ConversationID = $oItem.ConversationID
                EntryID = $oItem.EntryID

            }

            # ループ脱出
            $rr = $rr + 1
            if( $rr -gt $LimLoopCnt){break}
        }

} 

# CSVに吐き出す
$CsvData | ft -AutoSize

$tmp = "temp.csv"
$csvName = "ol_受信BOX_Items.csv"

#テンポラリファイル（csv）に書き出す
$CsvData | Export-Csv -Path $path$tmp -Encoding Default

#1行目を消して別名保存する（ これ→ "TYPE System.Management.Automation.PSCustomObject"）
Get-content $path$tmp | Select-Object -Skip 1 | Set-Content $path$csvName

#テンポラリファイルを削除する
Remove-Item $path$tmp

```

### Access 

``` vb
Option Compare Database
Option Explicit

Public Enum clm
  EntryID = 0
  件名
  本文
  受信日時
  添付ファイル
  送信者名
  受信者名
  CC
  No
End Enum

Private Sub Form_Load()
' チェックボックスにチェックを入れる
  chk送信箱.Value = -1
  chk受信箱.Value = -1
End Sub

Rem ==========================================
Rem メール検索
Rem ==========================================

' イベント部分
Private Sub txtKW件名_AfterUpdate()
  Call 検索結果を更新する
End Sub
Private Sub txtKW送信者_AfterUpdate()
  Call 検索結果を更新する
End Sub
Private Sub txtKW添付ファイル名_AfterUpdate()
  Call 検索結果を更新する
End Sub
Private Sub txtKW本文_AfterUpdate()
  Call 検索結果を更新する
End Sub
Private Sub chk受信箱_AfterUpdate()
  Call 検索結果を更新する
End Sub
Private Sub chk送信箱_AfterUpdate()
  Call 検索結果を更新する
End Sub

Private Sub btn検索条件クリア_Click()
  With Me
    .txtKW件名.Value = ""
    .txtKW本文.Value = ""
    .txtKW送信者.Value = ""
    .txtKW添付ファイル名.Value = ""
  End With
End Sub

' メイン部分
Private Sub 検索結果を更新する()
  Dim strSQL As String
  
  Dim KW件名 As String
  Dim KW本文 As String
  Dim KW送信者 As String
  Dim KW添付ファイル名 As String
  
  Dim 対象フォルダ As String
  対象フォルダ = Set対象フォルダ
  
  KW件名 = Null対策(Me.txtKW件名.Value)
  KW本文 = Null対策(Me.txtKW本文.Value)
  KW送信者 = Null対策(Me.txtKW送信者.Value)
  KW添付ファイル名 = Null対策(Me.txtKW添付ファイル名.Value)
  
'  strSQL = "SELECT * "
  strSQL = "SELECT EntryID,件名,本文,受信日時,添付ファイル,送信者名,受信者名,CC "
  strSQL = strSQL & "FROM MT_MailItems "
  strSQL = strSQL & "WHERE 件名 LIKE '*" & KW件名 & "*' "
  strSQL = strSQL & "AND 本文 LIKE '*" & KW本文 & "*' "
  strSQL = strSQL & "AND 送信者名 LIKE '*" & KW送信者 & "*' "
  strSQL = strSQL & "AND 添付ファイル LIKE '*" & KW添付ファイル名 & "*' "
  strSQL = strSQL & "AND フォルダ IN (" & 対象フォルダ & ") "
  
  Me.lst検索結果.RowSource = strSQL
  
End Sub

Private Function Null対策(str) As String
' 空文字を結合させるだけでNull回避できる。一番シンプルなやつ
  Null対策 = str & ""
  
' IIfを使った場合
'  Null対策 = IIf(IsNull(str), "", str)

' 普通にIf文で書いた場合
' 上の1行は以下の5行と同義。IIf便利
'  If IsNull(str) = True Then
'    Null対策 = ""
'  Else
'    Null対策 = str
'  End If
End Function


Private Function Set対象フォルダ()
  Dim arr() As String
  Dim k: k = -1
  
    If chk送信箱.Value = -1 Then
      k = k + 1
      ReDim Preserve arr(k)
      arr(k) = "'5'"
    End If
    
    If chk受信箱.Value = -1 Then
      k = k + 1
      ReDim Preserve arr(k)
      arr(k) = "'6'"
    End If

  Set対象フォルダ = Join(arr, ",")
End Function

Rem ==========================================
Rem ListBoxの選択アイテムをTextBoxに表示する
Rem ==========================================

Private Sub lst検索結果_AfterUpdate()
  With Me.lst検索結果
'    Call 本文を表示
    Me.txt本文詳細.Value = .Column(clm.本文)  'この方法だと軽いけど文字数制限がかかる。まあ詳細見たければOutlookで開いてみれば良いので軽さ優先でこっちにした。
    Me.txt件名詳細.Value = .Column(clm.件名)
    Me.txt受信日詳細.Value = .Column(clm.受信日時)
    Me.txt送信者詳細.Value = .Column(clm.送信者名)
    Me.txt受信者とCc.Value = .Column(clm.受信者名) & ";" & lst検索結果.Column(clm.CC)
    Me.txt添付ファイル名詳細.Value = .Column(clm.添付ファイル)
  End With
End Sub

Private Sub 本文を表示()

' SQLでやったら重さを感じた。まあ詳細見たければOutlookで開いてみれば良いので軽さ優先でこっちは不採用とした。
'  Dim strSQL As String
'  Dim rs As Recordset
'
'  With Me
'    strSQL = "SELECT 本文 "
'    strSQL = strSQL & "FROM MT_MailItems "
'    strSQL = strSQL & "WHERE EntryID = '" & .lst検索結果.Column(clm.EntryID) & "' "
'
'    Set rs = CurrentDb.OpenRecordset(strSQL)
'
'    .txt本文詳細.Value = rs![本文]
'  End With
'
'  Set rs = Nothing
End Sub

Rem ==========================================
Rem メールアイテムを開く
Rem ==========================================

' イベント部分
Private Sub lst検索結果_DblClick(Cancel As Integer)
  Dim EntryID As String: EntryID = lst検索結果.Column(clm.EntryID)
  Call EntryIDからメールを開く(EntryID)
End Sub

' メイン部分
Sub EntryIDからメールを開く(EntryID As String)
  'appOLを呼び出す
  Dim appOL As Outlook.Application
  Set appOL = New Outlook.Application

  Dim objMailItem As MailItem 'GetItemFromIDメソッドでEntryIDからメールアイテムを抽出する
  Set objMailItem = appOL.GetNamespace("MAPI").GetItemFromID(EntryID)
  
  objMailItem.Display
    
  'オブジェクトをNothingしておく
  Set appOL = Nothing
  Set objMailItem = Nothing
    
End Sub

```

## 感想
早速業務で大活躍してます。

Outlookのメール検索機能だと意に反するアイテムまでゴロゴロ出てくるのですが、これだと送信者名と件名でだいたい絞れますし、添付ファイル名をキーにする場合なんてこの1項目で瞬殺です。

- ある資料を送ったメンバーに更新版や追加分を送る
- 依頼書のファイル名から依頼メールを探して返信する

なんてシチュエーションが多々あるので早速戦力になってくれています。

テーブルの読み取り専用フォームなので事故のリスクや着手ハードルもなく、Access入門者としてなかなか良い題材チョイスだったと自画自賛です。