テスト107

Sub OlMail_Move()

'ExcelからOutlookを操作し、受信トレイから件名でメールを振り分け
'件名が「test」の場合はテスト1フォルダへ、件名が「テスト」の場合はテスト2フォルダへ移動させる
'(テスト1、テスト2フォルダは受信トレイと同じ階層に事前につくっておく)...〆(･ω･ )ﾒﾓﾒﾓ

Dim ol As outlook.Application
Dim INmail As Folder
Dim Fol1 As Folder
Dim Fol2 As Folder
Dim i As Variant
Dim cnt As Variant

Set ol = outlook.Application

With ol.GetNamespace("MAPI")
    '受信ボックスの取得
    Set INmail = .GetDefaultFolder(olFolderInbox)
    
    'Outlook内のテスト1フォルダの取得
    Set Fol1 = .Folders.Item(1).Folders.Item("テスト1")
    
    'Outlook内のテスト2フォルダの取得
    Set Fol2 = .Folders.Item(1).Folders.Item("テスト2")

End With


cnt = INmail.Items.Count
For i = cnt To 1 Step -1

    If InStr(INmail.Items(i).Subject, "test") > 0 Then
        '件名が「test」の場合はテスト1フォルダへ移動する
        INmail.Items(i).Move Fol1
        
    ElseIf InStr(INmail.Items(i).Subject, "テスト") > 0 Then
        '件名が「テスト」の場合はテスト2フォルダへ移動する
        INmail.Items(i).Move Fol2
            
    End If

Next i


End Sub

'Sub SearchGALForNameDirect()
'
'Dim olApp As outlook.Application
'Dim olNamespace As outlook.Namespace
'Dim olAddrList As outlook.AddressList
'Dim olAddrEntries As outlook.AddressEntries
'Dim olAddrEntry As outlook.AddressEntry
'Dim strName As String
'
'' 名前を設定します
'strName = "指定の名前"
'
'Set olApp = New outlook.Application
'Set olNamespace = olApp.GetNamespace("MAPI")
'Set olAddrList = olNamespace.AddressLists("グローバル アドレス一覧")
'Set olAddrEntries = olAddrList.AddressEntries
'
'On Error Resume Next
'Set olAddrEntry = olAddrEntries.Item(strName)
'If Not olAddrEntry Is Nothing Then
'    Debug.Print olAddrEntry.Name & " was found in the GAL."
'    Debug.Print "Email: " & olAddrEntry.GetExchangeUser.PrimarySmtpAddress
'Else
'    Debug.Print strName & " was not found in the GAL."
'End If
'On Error GoTo 0
'
'Set olAddrEntry = Nothing
'Set olAddrEntries = Nothing
'Set olAddrList = Nothing
'Set olNamespace = Nothing
'Set olApp = Nothing
'
'End Sub
'------------------------------------
'Sub SearchAddress()
'
'' Outlook.Application オブジェクトを作成
'Dim olApp As Object
'Set olApp = CreateObject("Outlook.Application")
'
'' Namespace オブジェクトを取得
'Dim olNS As Object
'Set olNS = olApp.GetNamespace("MAPI")
'
'' グローバルアドレス一覧を取得
'Dim olGAL As Object
'Set olGAL = olNS.GetGlobalAddressList
'
'' 検索キーを設定（ここでは例として "[e-mail]"）
'Dim SearchKey As String
'SearchKey = "[e-mail]"
'
'' グローバルアドレス一覧から検索キーに一致するアドレスを検索
'Dim olItem As Object
'Set olItem = olGAL.AddressEntries.Find("[SMTPAddress]='" & SearchKey & "'")
'
'' 検索結果を表示
'If Not olItem Is Nothing Then
'    MsgBox "Found: " & olItem.Name
'Else
'    MsgBox "Not Found"
'End If
'
'End Sub

'完全にOutlookを閉じてから処理を実行してみる