ソースコード

ソースコードの８０％は、AIがコーディングしたものです。
私は、「こんなことできますか？」、「こんなことしたいんだけど」と言うだけで、AIがコーディングしたソースコードをテストして、ｏｋとなったらツールに取り込む作業をしてきました。テストの成績は５０点ぐらいです。何回も作り直すこともありました。原因は質問の仕方にも問題がありましたが、私のパソコンの環境では、できないことが多かったように思います。

#ページ内目次

<クラスモジュール>　ThisOutlookSession

#Application イベント

Option Explicit         'ThisOutlookSession

'---------------------------------------
' Outlook 新着メールイベント用
'---------------------------------------
'処理に変更があった場合、モジュールの入れ替えを容易とするため、新着メール自動仕分けを呼び出すだけにしている。
Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    
    Call 新着メール自動仕分け(EntryIDCollection)

End Sub

'---------------------------------------
' Outlook 起動時（アプリ開始）
'---------------------------------------
Private Sub Application_Startup()
    
    Dim waitUntil As Double
    
    processingNewMail = True
    
    waitUntil = Timer + 2   ' 現在時刻＋2秒
    
    Do While Timer < waitUntil
        DoEvents             ' Outlookがフリーズしないようにする
    Loop

    Call ShowWaitForm

    logFilePath = Environ$("USERPROFILE") & "\MeiwakuLog.csv"
    logFileNum = FreeFile
    ' 古いログ（10日より前）を削除して再生成
    Call InitializeCsvLog
    
    '溜まってしまった迷惑メールを削除済みアイテム　フォルダーへ移動
    Call CleanOldJunkMails
    
    'start up時に溜まっていた未読メールを自動仕分けする
    Call Startup仕分け

    Call HideWaitForm

    processingNewMail = False

End Sub

'---------------------------------------
' Outlook 終了時（アプリ終了）
'---------------------------------------
Private Sub Application_Quit()

    On Error Resume Next

    If logFileNum <> 0 Then
        ' ファイル番号が開いていれば閉じる
        Close #logFileNum
        logFileNum = 0
    End If

End Sub

<標準モジュール>　

#ユーザー定義型・グローバル変数

‘===== ユーザー定義型 =====
Public Type TP800メール構成
固定No1 As Long
チェック対象メールアドレス As String
チェック対象フォルダー As String
迷惑メール仕分け先フォルダー As String
未読メール処理件数制限 As Long
End Type

Public Type TP300迷惑差出人
迷惑差出人番号 As Long
空白を除く As Boolean
小文字で比較 As Boolean
半角で比較 As Boolean
どちらから判定するか As Long
迷惑差出人キーワード As String
迷惑件数 As Integer
End Type

Public Type TP570正規ドメイン
正規ドメイン番号 As Long
正規ドメイン As String
差出人名 As String
End Type

Public Type TP600便利仕分け
便利仕分け番号 As Long
差出人名 As String
移動先フォルダー As String
outlook移動先Folder As Outlook.Folder
End Type

‘===== 共通で使うグローバル変数 =====
Public gLastModified As Date ‘ 最終更新日時記録

Public TypeTP800メール構成() As TP800メール構成

Public TypeTP300迷惑差出人_差出人から() As TP300迷惑差出人
Public cntTP300迷惑差出人_差出人から As Long

Public TypeTP300迷惑差出人_件名から() As TP300迷惑差出人
Public cntTP300迷惑差出人_件名から As Long

Public TypeTP570正規ドメイン() As TP570正規ドメイン
Public cntTP570正規ドメイン As Long

Public TypeTP600便利仕分け() As TP600便利仕分け
Public cntTP600便利仕分け As Long

Public globalintUnreadCount As Integer
Public dictContacts As Object ' Scripting.Dictionary
Public lastContactsModified As Date

‘===== 正規表現オブジェクトをモジュール全体で共有 =====
Public regEx As Object
Public processingNewMail As Boolean
‘=== ログ用　グローバル変数 ===
Public logFilePath As String
Public logFileNum As Integer

#新着メールイベント用

Sub 新着メール自動仕分け(ByVal EntryIDCollection As String)

    Dim arrIDs() As String
    Dim id As Variant
    
    Dim ns As Outlook.NameSpace
    Dim contactFolder As Outlook.Folder
    Dim store As Outlook.store
    Dim rootFolder As Outlook.Folder
    Dim NewMailFolder As Outlook.Folder
    Dim targetFolder As Outlook.Folder
    
    Dim item As Object
    
    ' 再入防止
    If processingNewMail Then
        Debug.Print "NewMailEx - reentry ignored: " & Now
        Exit Sub
    End If
    processingNewMail = True
    
    Call ShowWaitForm
    
    '---- Accessデータ読み込み-----
    Call NotNotAccessRecord
    
    With TypeTP800メール構成(1)
    
        Set ns = Application.GetNamespace("MAPI")
        Set contactFolder = ns.GetDefaultFolder(olFolderContacts)
        Set store = GetStoreByEmailAddress(.チェック対象メールアドレス, ns)
        If store Is Nothing Then
            Debug.Print "Store not found: " & .チェック対象メールアドレス
            GoTo CleanUp
        End If

        Set rootFolder = store.GetRootFolder
        Set NewMailFolder = rootFolder.Folders(.チェック対象フォルダー)
        Set targetFolder = rootFolder.Folders(.迷惑メール仕分け先フォルダー)
    
    End With
    
   ' EntryIDCollection は複数カンマ区切りが来ることがある
   
    arrIDs = Split(EntryIDCollection, ",")
    
    For Each id In arrIDs
        
        Set item = Nothing
        
        On Error Resume Next
        
        Set item = ns.GetItemFromID(Trim(id))
        
        On Error GoTo 0
        
        If Not item Is Nothing Then
            
            If TypeName(item) = "MailItem" Then
                
                If item.Parent.EntryID = NewMailFolder.EntryID Then
                
                    Call ProcessMailItem(item, targetFolder, contactFolder)
                
                End If
            
            End If
        
        End If
    
    Next id
   
     ' 受信処理が追いつかないときは未読処理を短時間で試す（最大X回）
    Dim waitUntil As Double
    Dim retry As Integer
    
    retry = 0
    globalintUnreadCount = 1

    Do While globalintUnreadCount > 0 And retry < 10
        ' 短いインターバル（2秒）で再実行。長い待機は避ける。
        
        waitUntil = Timer + 2   ' 現在時刻＋2秒
        
        Do While Timer < waitUntil
            DoEvents             ' Outlookがフリーズしないようにする
        Loop
        
        Call 未読メール自動仕分け
        retry = retry + 1
    Loop

CleanUp:

    Call HideWaitForm
    
    processingNewMail = False
    
End Sub

#受信トレイの未読メールを自動仕分け

Sub 未読メール自動仕分け()

    Dim ns As Outlook.NameSpace
    Dim colFiltered As Outlook.items
    Dim store As Outlook.store
    Dim rootFolder As Outlook.Folder
    Dim inbox As Outlook.Folder
    Dim targetFolder As Outlook.Folder
    Dim contactFolder As Outlook.Folder
    
    Dim col As Outlook.items
    Dim obj As Object
    Dim item As MailItem
    Dim i As Long
    Dim forCount As Long
    
    If Not processingNewMail Then
        Call ShowWaitForm
    End If
    
    '---- Accessデータ読み込み-----
    Call NotNotAccessRecord
    
    With TypeTP800メール構成(1)
    
        Set ns = Application.GetNamespace("MAPI")
        Set store = GetStoreByEmailAddress(.チェック対象メールアドレス, ns)
        If store Is Nothing Then
            Debug.Print "Store not found: " & .チェック対象メールアドレス
            Exit Sub
        End If
        Set rootFolder = store.GetRootFolder
        Set inbox = rootFolder.Folders(.チェック対象フォルダー)
    
        Set contactFolder = ns.GetDefaultFolder(olFolderContacts)
        Set targetFolder = rootFolder.Folders(.迷惑メール仕分け先フォルダー)
        forCount = .未読メール処理件数制限
        
    End With
        
    ' 未読だけを取り出す
    Set col = inbox.items
    Set colFiltered = col.Restrict("[MessageClass] = 'IPM.Note' AND [UnRead] = True")
    
    globalintUnreadCount = 0
    
    If colFiltered.Count < forCount Then
        forCount = colFiltered.Count
    End If

    For i = forCount To 1 Step -1
    
        Set obj = Nothing
        Set obj = colFiltered.item(i)
        
        If TypeName(obj) = "MailItem" Then
            
            Set item = obj
            
            If ProcessMailItem(item, targetFolder, contactFolder) Then ' 共通処理を呼び出し
                globalintUnreadCount = globalintUnreadCount + 1
            End If
            DoEvents
            
        End If
    
    Next i
    
    If Not processingNewMail Then
        Call HideWaitForm
    End If

End Sub

'-----------------------------------------
' Startupイベントで、数秒待って未読メール自動仕分けを呼び出す
'-----------------------------------------
Public Function Startup仕分け()

    'Outlook起動時に数秒待ってから処理を実行

    Dim waitUntil As Double
    Dim retry As Integer
    
    retry = 0
    globalintUnreadCount = 1

    Do While globalintUnreadCount > 0 And retry < 10
        ' 短いインターバル（2秒）で再実行。長い待機は避ける。
        
        waitUntil = Timer + 2   ' 現在時刻＋2秒
        
        Do While Timer < waitUntil
            DoEvents             ' Outlookがフリーズしないようにする
        Loop
        
        Call 未読メール自動仕分け
        retry = retry + 1
    Loop

End Function

＃選択したメールを自動仕分け

Sub 選択したメール自動仕分け()

    Dim ns As Outlook.NameSpace
    Dim contactFolder As Outlook.Folder
    Dim store As Outlook.store
    Dim rootFolder As Outlook.Folder
    Dim targetFolder As Outlook.Folder
    Dim forCount As Long

    Call ShowWaitForm

    '---- Accessデータ読み込み-----
    Call NotNotAccessRecord
    
    With TypeTP800メール構成(1)
    
        Set ns = Application.GetNamespace("MAPI")
        Set contactFolder = ns.GetDefaultFolder(olFolderContacts)
        Set store = GetStoreByEmailAddress(.チェック対象メールアドレス, ns)
        If store Is Nothing Then
            Debug.Print "Store not found: " & .チェック対象メールアドレス
            Exit Sub
        End If
        Set rootFolder = store.GetRootFolder
        Set targetFolder = rootFolder.Folders(.迷惑メール仕分け先フォルダー)
        forCount = .未読メール処理件数制限

    End With

    Dim objOutlook As Outlook.Application
    Dim objSelection As Outlook.Selection
    Dim i As Long

    Set objOutlook = Outlook.Application
    Set objSelection = objOutlook.ActiveExplorer.Selection
    
    Dim inbox As Outlook.Folder
    Dim item As MailItem
    
    If objSelection.Count < forCount Then
        forCount = objSelection.Count
    End If
    
    For i = forCount To 1 Step -1
        If TypeName(objSelection.item(i)) = "MailItem" Then
            
            Set item = objSelection.item(i)
            
            ProcessMailItem item, targetFolder, contactFolder    ' 共通処理を呼び出し
            DoEvents
        
        End If
    Next i
    
    Call HideWaitForm

End Sub

＃迷惑メールの判定処理


Function ProcessMailItem(item As Outlook.MailItem, targetFolder As Outlook.Folder, contactFolder As Outlook.Folder) As Boolean

    Dim stitem_SenderName As String
    Dim i As Long
    Dim k As Long
    Dim contact As Outlook.ContactItem
    
    Dim strKeyWord As String
    Dim strMailData As String

' ===== 仕分け条件（ここだけ直せば両方に反映） =====
    
    ProcessMailItem = False
    
    If item.SenderName <> item.SentOnBehalfOfName Then
        stitem_SenderName = item.SentOnBehalfOfName
    Else
        stitem_SenderName = item.SenderName
    End If
    
'********************　まず、便利機能の自動仕分けを行う　********************

    For i = 1 To cntTP600便利仕分け
    
        With TypeTP600便利仕分け(i)
            
            If stitem_SenderName Like "*" & .差出人名 & "*" Then
            
                Call WriteLog(.outlook移動先Folder, "便利仕分け", .差出人名, item)
                item.Move .outlook移動先Folder
                
                GoTo Seijyou_mail
    
            End If
    
        End With
        
    Next

'********************　連絡先に登録されているメールアドレスは正常メール　********************
    
    '==== 未作成時、または変更があれば連絡先のキャッシュを作る ====
    Call RefreshContactsIfNeeded
    
    'キャッシュ化された連絡先を参照
    If Not dictContacts Is Nothing Then
        
        If dictContacts.Exists(LCase(item.SenderEmailAddress)) Then
            Call WriteLog("正常メール", "連絡先", item.SenderEmailAddress, item)
            GoTo Seijyou_mail
        End If
    
    End If
    
'********************　正常メールと迷惑メールが混在している差出人は、メールアドレスのドメインかをチェックし、正規のドメインであれば迷惑メールの判定を止める　********************
         
    For i = 1 To cntTP570正規ドメイン
    
        With TypeTP570正規ドメイン(i)
            
            If LCase(item.SenderEmailAddress) Like "*" & .正規ドメイン Then
            
                Call WriteLog("正常メール", "正規ドメイン", .正規ドメイン, item)
                GoTo Seijyou_mail
    
            End If
    
        End With
        
    Next
    
'********************　迷惑メールが送られてくる差出人を判定する　********************
    
    '---- 差出人から ----
    
    For i = 1 To cntTP300迷惑差出人_差出人から
    
        With TypeTP300迷惑差出人_差出人から(i)
            
            strMailData = stitem_SenderName
            
            strKeyWord = .迷惑差出人キーワード
            
            If .空白を除く Then
            
                 strMailData = RemoveSpaces(strMailData)
                 strKeyWord = RemoveSpaces(strKeyWord)
            
            End If
            
            If .小文字で比較 Then
            
                 strMailData = funcLCase(strMailData)
                 strKeyWord = funcLCase(strKeyWord)
            
            End If
            
            If .半角で比較 Then
            
                 strMailData = Half_Width(strMailData)
                 strKeyWord = Half_Width(strKeyWord)
            
            End If
            
            If strMailData Like "*" & strKeyWord & "*" Then
            
                .迷惑件数 = .迷惑件数 + 1
                Call WriteLog("迷惑メール", "差出人から", .迷惑差出人キーワード, item)
                GoTo Meiwaku_mail
            
            End If
    
        End With

    Next
    
    '---- 件名から ----
    For i = 1 To cntTP300迷惑差出人_件名から
    
        With TypeTP300迷惑差出人_件名から(i)
         
            strMailData = item.Subject
            
            strKeyWord = .迷惑差出人キーワード
            
            If .空白を除く Then
            
                 strMailData = RemoveSpaces(strMailData)
                 strKeyWord = RemoveSpaces(strKeyWord)
            
            End If
            
            If .小文字で比較 Then
            
                 strMailData = funcLCase(strMailData)
                 strKeyWord = funcLCase(strKeyWord)
            
            End If
            
            If .半角で比較 Then
            
                 strMailData = Half_Width(strMailData)
                 strKeyWord = Half_Width(strKeyWord)
            
            End If
            
            If strMailData Like "*" & strKeyWord & "*" Then
            
                .迷惑件数 = .迷惑件数 + 1
                Call WriteLog("迷惑メール", "件名から", .迷惑差出人キーワード, item)
                GoTo Meiwaku_mail
            
            End If
    
        End With
    
    Next

'********************　特殊文字を含む差出人は、迷惑メールと判定する　********************

    If regEx Is Nothing Then
        InitRegEx
    End If
    
    If regEx.test(stitem_SenderName) Then
        Call WriteLog("迷惑メール", "特殊文字", stitem_SenderName, item)
        GoTo Meiwaku_mail
    End If

    ' ===============================================
    Call WriteLog("正常メール", "どれでもない", "", item)

Seijyou_mail:
    
    Exit Function
    
Meiwaku_mail:
    On Error Resume Next
        item.Move targetFolder
    On Error GoTo 0
    
    ProcessMailItem = True
    Exit Function
    
End Function

＃古い迷惑メールを削除済みアイテムに移動する

Function CleanOldJunkMails()

    Dim ns As Outlook.NameSpace
    Dim store As Outlook.store
    Dim rootFolder As Outlook.Folder
    
    Dim targetFolder As Outlook.Folder
    Dim delFolder As Outlook.Folder
    Dim items As Outlook.items
    Dim mail As MailItem
    Dim i As Long
    Dim limitDate As Date

    On Error GoTo ErrHandler

    '---- Accessデータ読み込み-----
    Call NotNotAccessRecord
    
    With TypeTP800メール構成(1)
    
        Set ns = Application.GetNamespace("MAPI")
        Set store = GetStoreByEmailAddress(.チェック対象メールアドレス, ns)
        If store Is Nothing Then
            Debug.Print "Store not found: " & .チェック対象メールアドレス
            GoTo ErrHandler
        End If

        Set rootFolder = store.GetRootFolder
        Set targetFolder = rootFolder.Folders(.迷惑メール仕分け先フォルダー)
        ' 削除済みアイテム
        Set delFolder = ns.GetDefaultFolder(olFolderDeletedItems)
    
    End With


    ' 10日前の日付
    limitDate = Now - 10
    
    Set items = targetFolder.items

    ' 日付順で安定させる
    items.Sort "[ReceivedTime]", True

    For i = items.Count To 1 Step -1

        If TypeName(items(i)) = "MailItem" Then
            Set mail = items(i)

            ' 10日より前なら削除済みに移動
            If mail.ReceivedTime < limitDate Then
                mail.Move delFolder
            End If

        End If

    Next i

    Exit Function

ErrHandler:
    Debug.Print "Error in CleanOldJunkMails: " & Err.Number & " - " & Err.Description

End Function

＃Accessのテーブルをoutlookから読み込むモジュール群

Function NotNotAccessRecord()

    Dim conn As Object
    Dim rs As Object
    Dim dbPath As String
    Dim sql As String
    Dim rec As Object   ' Scripting.Dictionary
    Dim fs As Object
    Dim connStr As String
    Dim i As Long
    
    
    
    ' Accessファイルのパス
    dbPath = Environ("USERPROFILE") & "\OutLook.accdb"
    
    ' Accessファイルの最終更新日時取得
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    Dim currentModified As Date
    
    currentModified = fs.GetFile(dbPath).DateLastModified
    
    Set fs = Nothing
    
    If (Not Not TypeTP800メール構成) <> 0 Then
        
        If currentModified = gLastModified Then
        
            Exit Function
    
        End If
        
    End If

    ' --- 再読込処理 ---
    connStr = GetAccessConnectionString(dbPath)
    If connStr = "" Then Exit Function  ' 接続不可の場合は中断
    
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    conn.Open connStr
    
'==== TP800メール構成 ====
    
    Call OpenRs(rs, conn, "SELECT * FROM [TP800メール構成]")

    ' 配列のサイズを決定
    ReDim TypeTP800メール構成(1 To rs.RecordCount)
    
    If Not rs.EOF Then
        rs.MoveLast
        rs.MoveFirst

        i = 1
            
        Do Until rs.EOF
            
            With TypeTP800メール構成(i)
            
                .固定No1 = rs!固定No1
                .チェック対象メールアドレス = rs!チェック対象メールアドレス
                .チェック対象フォルダー = rs!チェック対象フォルダー
                .迷惑メール仕分け先フォルダー = rs!迷惑メール仕分け先フォルダー
                .未読メール処理件数制限 = rs!未読メール処理件数制限
                
                i = i + 1
                rs.MoveNext
        
            End With
        
        Loop
            
    
    End If

'==== TP300迷惑差出人 ====
    
    '---- 差出人から ----
    Call OpenRs(rs, conn, "SELECT * FROM [TP300迷惑差出人] where [どちらから判定するか] = 1 Order By [迷惑差出人番号]")
    
    ' 配列のサイズを決定
    cntTP300迷惑差出人_差出人から = 0
    
    If Not rs.EOF Then
        rs.MoveLast
        ReDim TypeTP300迷惑差出人_差出人から(1 To rs.RecordCount)
        rs.MoveFirst

        i = 1
        
        Do Until rs.EOF
                
            With TypeTP300迷惑差出人_差出人から(i)
                
                .迷惑差出人番号 = rs!迷惑差出人番号
                .空白を除く = rs!空白を除く
                .小文字で比較 = rs!小文字で比較
                .半角で比較 = rs!半角で比較
                .どちらから判定するか = rs!どちらから判定するか
                .迷惑差出人キーワード = rs!迷惑差出人キーワード
                .迷惑件数 = 0
                i = i + 1
                rs.MoveNext
        
            End With
        
        Loop
    
        cntTP300迷惑差出人_差出人から = i - 1

    End If

    '---- 件名から ----
    Call OpenRs(rs, conn, "SELECT * FROM [TP300迷惑差出人] where [どちらから判定するか] = 2 Order By [迷惑差出人番号]")
    
    ' 配列のサイズを決定
    cntTP300迷惑差出人_件名から = 0
    
    If Not rs.EOF Then
        rs.MoveLast
        ReDim TypeTP300迷惑差出人_件名から(1 To rs.RecordCount)
        rs.MoveFirst

        i = 1
        
        Do Until rs.EOF
                
            With TypeTP300迷惑差出人_件名から(i)
                
                .迷惑差出人番号 = rs!迷惑差出人番号
                .空白を除く = rs!空白を除く
                .小文字で比較 = rs!小文字で比較
                .半角で比較 = rs!半角で比較
                .どちらから判定するか = rs!どちらから判定するか
                .迷惑差出人キーワード = rs!迷惑差出人キーワード
                .迷惑件数 = 0
                i = i + 1
                rs.MoveNext
        
            End With
        
        Loop
    
        cntTP300迷惑差出人_件名から = i - 1
    
    End If


'==== TP570正規ドメイン ====

    Call OpenRs(rs, conn, "SELECT * FROM [TP570正規ドメイン] Order By [正規ドメイン番号]")
    
    ' 配列のサイズを決定
    cntTP570正規ドメイン = 0
    
    If Not rs.EOF Then
        rs.MoveLast
        ReDim TypeTP570正規ドメイン(1 To rs.RecordCount)
        rs.MoveFirst

        i = 1
        
        Do Until rs.EOF
    
            With TypeTP570正規ドメイン(i)
    
                .正規ドメイン番号 = rs!正規ドメイン番号
                .正規ドメイン = rs!正規ドメイン
                .差出人名 = IIf(IsNull(rs!差出人名), "", rs!差出人名)
                i = i + 1
                rs.MoveNext
        
            End With
        
        Loop
    
        cntTP570正規ドメイン = i - 1
    
    End If

'==== TP600便利仕分け ====

    Dim ns As Outlook.NameSpace
    Dim store As Outlook.store
    Dim rootFolder As Outlook.Folder
    Dim targetFolder As Outlook.Folder
    
    Set ns = Application.GetNamespace("MAPI")
    Set store = GetStoreByEmailAddress(TypeTP800メール構成(1).チェック対象メールアドレス, ns)
    If store Is Nothing Then
        Debug.Print "Store not found: " & TypeTP800メール構成(1).チェック対象メールアドレス
        Exit Function
    End If
    Set rootFolder = store.GetRootFolder
        
    Call OpenRs(rs, conn, "SELECT * FROM [TP600便利仕分け] Order By [便利仕分け番号]")
    
    ' 配列のサイズを決定
    cntTP600便利仕分け = 0
    
    If Not rs.EOF Then
        rs.MoveLast
        ReDim TypeTP600便利仕分け(1 To rs.RecordCount)
        rs.MoveFirst

        i = 1
        
        Do Until rs.EOF
    
            With TypeTP600便利仕分け(i)
    
                .便利仕分け番号 = rs!便利仕分け番号
                .差出人名 = rs!差出人名
                .移動先フォルダー = rs!移動先フォルダー
                Set .outlook移動先Folder = rootFolder.Folders(.移動先フォルダー)
                i = i + 1
                rs.MoveNext
        
            End With
        
        Loop
    
        cntTP600便利仕分け = i - 1
    
    End If


'==== 終了 ====
    
    '最終更新日を更新
    gLastModified = currentModified
    
    rs.Close
    Set rs = Nothing
    
    conn.Close
    Set conn = Nothing
    
End Function

'#連絡先をキャッシュに保存する関係の関数群

Function RefreshContactsIfNeeded()

    Dim ns As Outlook.NameSpace
    Dim fld As Outlook.MAPIFolder
    Dim datelastContactsTemp As Date

    Set ns = Application.GetNamespace("MAPI")
    Set fld = ns.GetDefaultFolder(olFolderContacts)

    ' 最新キャッシュに作り直しのチェック（未作成、最終更新日時を比較）
    If dictContacts Is Nothing Then
    
        ' ==== 最新キャッシュに作り直し ====
        Call BuildDictContacts
        
        ' ==== 更新日時を記録 ====
        lastContactsModified = GetContactsLastModified(fld)
        
'        Debug.Print " dictContacts を新規に構築しました"
    
    Else
        datelastContactsTemp = GetContactsLastModified(fld)
        If datelastContactsTemp <> lastContactsModified Then
        
            ' ==== 最新キャッシュに作り直し ====
            Call BuildDictContacts
            
            ' ==== 更新日時を記録 ====
            lastContactsModified = datelastContactsTemp
            
'            Debug.Print "連絡先が更新されたため dictContacts を再構築しました"
        Else
'            Debug.Print "連絡先に変更なし（dictContacts の再構築は不要）"
        End If
    End If

End Function

'--------------------------------------
' 連絡先フォルダーの「最終更新日時」を取得
'--------------------------------------
Function GetContactsLastModified(fld As Outlook.Folder) As Date

    Dim item As Object
    Dim latest As Date
    latest = #1/1/1900#
    
    For Each item In fld.Items
        If TypeName(item) = "ContactItem" Then
            If item.LastModificationTime > latest Then
                latest = item.LastModificationTime
            End If
        End If
    Next item
    
    GetContactsLastModified = latest
    
End Function

'--------------------------------------
' 連絡先をキャッシュに保存
'--------------------------------------
Function BuildDictContacts()

    Dim ns As Outlook.NameSpace
    
    Set ns = Application.GetNamespace("MAPI")
    Set dictContacts = CreateObject("Scripting.Dictionary")
    
    Dim con As Object
    Dim c As Long
    Set con = ns.GetDefaultFolder(olFolderContacts).Items

    For c = 1 To con.Count

        If TypeName(con(c)) = "ContactItem" Then

            On Error Resume Next

            If Not IsNull(con(c).Email1Address) And con(c).Email1Address <> "" Then
                dictContacts(LCase(con(c).Email1Address)) = True
            End If

            If Not IsNull(con(c).Email2Address) And con(c).Email2Address <> "" Then
                dictContacts(LCase(con(c).Email2Address)) = True
            End If

            If Not IsNull(con(c).Email3Address) And con(c).Email3Address <> "" Then
                dictContacts(LCase(con(c).Email3Address)) = True
            End If

            On Error GoTo 0

        End If

    Next c
    
End Function

#正規表現オブジェクト生成

Function InitRegEx()


    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True

    ' 日本語・英数字・一般的な記号のみ許可
    ' → それ以外の文字（例: ?????）を検出
    regEx.Pattern = "[^0-9 -/:-@A-Za-zＡ-Ｚａ-ｚ[-`{-~ぁ-んァ-ヶ一-﨩々ー・‐-※　-～]"
'    regEx.Pattern = "[^0-9A-Za-zＡ-Ｚａ-ｚ " & """'ぁ-んァ-ヶ一-鶴々ー・、。,.@\-_　［］]"
    
End Function

#文字列処理系関数群


    RemoveSpaces = Replace(Replace(strWord, " ", ""), "　", "")

End Function

Function funcLCase(strWord As String) As String

    funcLCase = LCase(strWord)

End Function

Function Half_Width(strWord As String) As String

    Half_Width = StrConv(strWord, vbNarrow)

End Function

#メールアドレスからストアを特定する

Function GetStoreByEmailAddress(email As String, ns As Outlook.NameSpace) As Outlook.store
    
    Dim acc As Outlook.Account
    
    Set GetStoreByEmailAddress = Nothing
    
    For Each acc In ns.Accounts
        If LCase(acc.SmtpAddress) = LCase(email) Then
            Set GetStoreByEmailAddress = acc.DeliveryStore
            Exit Function
        End If
    Next
    
    If GetStoreByEmailAddress Is Nothing Then
        MsgBox ("まず、メールアドレスなどのメール構成を登録してください。処理を終了します。")
    End If
    
End Function

#選択したメールのから迷惑メール判定情報を登録するAccess画面を呼び出す ===

#Access画面を呼び出す

Sub Access選択メールから登録()

    Dim accApp  As Object
    Dim sql As String
    Dim dbPath As String
    Dim formName As String
        
    dbPath = Environ("USERPROFILE") & "\OutLook.accdb"
    formName = "FP100選択メール_21更新開始"
    
    ' Accessを起動
    On Error Resume Next
    Set accApp = GetObject(, "Access.Application")
    If accApp Is Nothing Then
        Set accApp = CreateObject("Access.Application")
    Else
        MsgBox ("「選択したメールの処理」画面が、Accessが開かれたままなので表示できません。終了します。")
        Exit Sub
    End If
    On Error GoTo 0
    
    ' Accessを操作できるように
    accApp.Visible = True

    ' データベースを開く
    accApp.OpenCurrentDatabase dbPath
    
    DoEvents
    DoEvents
    DoEvents
    
    ' 指定したフォームを開く
    accApp.DoCmd.OpenForm formName
    
    DoEvents
    DoEvents
    DoEvents
    
'    accApp.Close
'    Set accApp  = Nothing
    
End Sub

'#メール構成（メールアドレス、フォルダー名など）を登録するAccess画面を呼び出す ===

Sub Accessメール構成を登録()

    Dim accApp  As Object
    Dim sql As String
    Dim dbPath As String
    Dim formName As String
        
    dbPath = Environ("USERPROFILE") & "\OutLook.accdb"
    formName = "FP800メール構成_21更新開始"
    
    ' Accessを起動
    On Error Resume Next
    Set accApp = GetObject(, "Access.Application")
    If accApp Is Nothing Then
        Set accApp = CreateObject("Access.Application")
    Else
        MsgBox ("「メール構成を登録」画面が、Accessが開かれたままなので表示できません。終了します。")
        Exit Sub
    End If
    On Error GoTo 0
    
    ' Accessを操作できるように
    accApp.Visible = True

    ' データベースを開く
    accApp.OpenCurrentDatabase dbPath
    
    DoEvents
    DoEvents
    DoEvents
    
    ' 指定したフォームを開く
    accApp.DoCmd.OpenForm formName

    DoEvents
    DoEvents
    DoEvents

End Sub

#Accessデータ読み込みまわりの関数

'----Accessの接続文字列を自動選択して返す関数----
'=========================================
' 対応:
'   ・Access 2003 (.mdb) : Jet 4.0
'   ・Access 2007以降 (.accdb) : ACE 12.0 / 16.0
'   ・Office 32/64bit 両対応
'=========================================
Function GetAccessConnectionString(ByVal dbPath As String) As String
    Dim ext As String
    Dim connStr As String
    Dim provider As String
    Dim fso As Object
    Dim testConn As Object

    ' ファイル存在チェック
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(dbPath) Then
        Err.Raise vbObjectError + 100, , "指定されたAccessファイルが存在しません: " & dbPath
        Exit Function
    End If
    ext = LCase(fso.GetExtensionName(dbPath))
    Set fso = Nothing

    ' デフォルトはACE 16.0
    provider = "Microsoft.ACE.OLEDB.16.0"

    ' .mdb形式の場合は古い形式なのでJetを優先
    If ext = "mdb" Then
        provider = "Microsoft.Jet.OLEDB.4.0"
    End If

    ' 接続テストオブジェクトを作成
    Set testConn = CreateObject("ADODB.Connection")

    '--- ACE 16.0 を試す ---
    On Error Resume Next
    testConn.Open "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & dbPath
    If Err.Number = 0 Then
        provider = "Microsoft.ACE.OLEDB.16.0"
    Else
        Err.Clear
        '--- ACE 12.0 を試す ---
        testConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
        If Err.Number = 0 Then
            provider = "Microsoft.ACE.OLEDB.12.0"
        Else
            Err.Clear
            '--- Jet 4.0 を試す ---
            testConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath
            If Err.Number = 0 Then
                provider = "Microsoft.Jet.OLEDB.4.0"
            Else
                Err.Clear
                MsgBox "Access接続ドライバ（ACE/Jet）が見つかりませんでした。" & vbCrLf & _
                       "Access Database Engineをインストールしてください。", vbCritical
                provider = ""
            End If
        End If
    End If
    On Error GoTo 0

    ' 接続を閉じる
    On Error Resume Next
    testConn.Close
    Set testConn = Nothing
    On Error GoTo 0

    ' 最終的な接続文字列を返す
    If provider <> "" Then
        connStr = "Provider=" & provider & ";Data Source=" & dbPath
        GetAccessConnectionString = connStr
    End If
    
End Function

'---- outlookからAccessのテーブルを読み込む
Function OpenRs(ByRef rs As Object, ByRef conn As Object, ByVal sql As String)

    If Not rs Is Nothing Then
        If rs.State <> 0 Then rs.Close
        Set rs = Nothing
    End If
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open sql, conn, 1, 1

End Function

＃CSVログ関係のプログラム群


'----------------------------------------------------
' CSVログの初期化（10日前より古いログを削除）
'----------------------------------------------------
Public Function InitializeCsvLog()

    Dim tempFile As String
    Dim oldDate As Date
    Dim f As Integer, t As Integer
    Dim line As String
    Dim fields As Variant

    oldDate = Now - 10
    tempFile = logFilePath & ".tmp"

    'ログファイルを使用中の Excel を閉じる
    Call CloseCSVFileIfOpen(logFilePath)
    
    ' ファイルが無ければ作成
    If Dir(logFilePath) = "" Then
        f = FreeFile
        Open logFilePath For Output As #f
        Print #f, "仕分け日時,仕分け先,仕分け元,対象item,受信日時,差出人,メールアドレス,件名,本文"
        Close #f
    End If

    ' 古い行を削除したファイルを作る
    f = FreeFile
    Open logFilePath For Input As #f

    t = FreeFile
    Open tempFile For Output As #t

    Do While Not EOF(f)
        Line Input #f, line

        fields = Split(line, ",")

        ' ヘッダ行 or 日付チェック
        If fields(0) = "仕分け日時" Then
            Print #t, line
        Else
            If IsDate(fields(0)) Then
                If CDate(fields(0)) >= oldDate Then
                    Print #t, line
                End If
            End If
        End If
    Loop

    Close #f
    Close #t

    ' 上書き
    Kill logFilePath
    Name tempFile As logFilePath

    ' 書き込み用にオープン
    logFileNum = FreeFile
    Open logFilePath For Append As #logFileNum

End Function

'============================
' 指定 CSV が Excel で開かれていたら閉じる
'============================
Public Sub CloseCSVFileIfOpen(ByVal logFilePath As String)

    Dim xlApp As Object
    Dim wb As Object
    Dim isOpened As Boolean
    isOpened = False
    
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    On Error GoTo 0
    
    If Not xlApp Is Nothing Then
        ' Excelが起動している場合
        For Each wb In xlApp.Workbooks
            If LCase(wb.FullName) = LCase(logFilePath) Then
                isOpened = True
                wb.Close SaveChanges:=False  ' CSVだけ閉じる（Excelは閉じない）
                Exit For
            End If
        Next wb
    End If
    
    Set wb = Nothing
    Set xlApp = Nothing

End Sub

'-----------------------------------------
' CSVログに1行追加する関数（本文200文字制限）
'-----------------------------------------
Public Sub WriteLog( _
        ByVal resultFolder As String, _
        ByVal reason As String, _
        ByVal targetData As String, _
        ByVal mail As Outlook.MailItem _
    )

    Dim cleanBody As String
    Dim tmpBody As String

    ' 改行 → スペース、カンマ → スペース
    tmpBody = Replace(Replace(mail.Body, vbCrLf, " "), ",", " ")

    ' 200文字までに制限
    If Len(tmpBody) > 200 Then
        cleanBody = Left(tmpBody, 200) & "..."
    Else
        cleanBody = tmpBody
    End If

    Print #logFileNum, _
        Format(Now, "yyyy/mm/dd hh:nn:ss") & "," & _
        resultFolder & "," & _
        reason & "," & _
        Replace(targetData, ",", " ") & "," & _
        Format(mail.ReceivedTime, "yyyy/mm/dd hh:nn:ss") & "," & _
        Replace(mail.SenderName, ",", " ") & "," & _
        Replace(mail.SenderEmailAddress, ",", " ") & "," & _
        Replace(mail.Subject, ",", " ") & "," & _
        cleanBody

End Sub

'--------------------------------------
' CSVをExcelで開く
'--------------------------------------
Public Sub OpenLogCsv()

    Dim xl As Object
    Dim book As Object

    Set xl = CreateObject("Excel.Application")
    xl.Visible = True

    Set book = xl.Workbooks.Open(logFilePath)

End Sub

＃ちょっとしたプログラム

'--------------------------------------
' ホームページを開く
'--------------------------------------
Sub OpenHomePage()

    Dim URL As String
    URL = "http://system-kisaku.net/"
    Shell "cmd /c start " & URL, vbHide
    
End Sub

'--------------------------------------
' お待ちくださいフォームを開く
'--------------------------------------
Function ShowWaitForm()

    On Error Resume Next
    frmWait.Show vbModeless
    DoEvents

End Function

'--------------------------------------
' お待ちくださいフォームを開く
'--------------------------------------
Function HideWaitForm()

    On Error Resume Next
    Unload frmWait

End Function

#ページ内目次

<クラスモジュール> ThisOutlookSession

#Application イベント

<標準モジュール>

#ユーザー定義型・グローバル変数

#新着メールイベント用

#受信トレイの未読メールを自動仕分け

＃選択したメールを自動仕分け

＃迷惑メールの判定処理

＃古い迷惑メールを削除済みアイテムに移動する

＃Accessのテーブルをoutlookから読み込む モジュール群

#正規表現オブジェクト生成

#文字列処理系関数群

#メールアドレスからストアを特定する

#Access画面を呼び出す

#Accessデータ読み込みまわりの関数

＃CSVログ関係のプログラム群

＃ちょっとしたプログラム

<クラスモジュール>　ThisOutlookSession

<標準モジュール>　

＃Accessのテーブルをoutlookから読み込むモジュール群