LoginSignup
3
3

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 5 years have passed since last update.

@Q11Q

OUTLOOK VBA 検索のサンプル

Last updated at Posted at 2017-04-11

##検索の方針

  1. まず日付を絞りこむ
  2. 次にタイトルを絞り込む
  3. できればメールアドレスで絞り込む（その後ある程度成功）
  4. それをメールに保存する。
  5. タスクの保存は調査中。

##実際に動いたものを上げてみる
##事前の準備作業
イヴェントプロシージャ(Thisoutlooksession)などに書き込む、パブリック変数の宣言、サブルーチン、関数
などを標準モジュールに用意する。

クィック検索を有効にする。

thisoutlookSessionに2つのイベントプロシージャを設定

Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
'タグがTestから始まる時は以外は検索オブジェクトに格納されたデータの整合性を確保するため、 AdvancedSearchCompleteイベント サブルーチンとなります
'https://msdn.microsoft.com/ja-jp/library/office/ff869970.aspx
 Dim objRsts As Outlook.Results
  Dim Item As Outlook.MailItem
  Debug.Print "The AdvancedSearchComplete Event fired"
    If SearchObject.Tag Like "Test*" Then
        blnSearchComp = True
 Else
 MsgBox "The search " & SearchObject.Tag & "has finished. The filter used was " & _
 SearchObject.Filter & "."
 Set objRsts = SearchObject.Results
 
'Print out number in results collection
MsgBox objRsts.Count
  'Print out each member of results collection
For Each Item In objRsts
 MsgBox Item
Next
 End If
End Sub

Private Sub Application_AdvancedSearchStopped(ByVal SearchObject As Search)
    'Inform the user that the search has stopped.
    MsgBox "An AdvancedSearch has been interrupted and stopped. "
    blnSeachStop = True
End Sub

###Public変数を標準モジュールのDeclareに宣言

Public blnSearchComp As Boolean
Public blnSearchStop As Boolean

###ユーザー定義関数とサブルーチン
メールの保存のために使う。以前紹介したものをサブルーチンプロシージャ化した。
以前の記事でユーザーファンクションを作成して使用している場合は、ユーザーファンクションをコピペする必要はありません。

###Items.restrict用メールをMSG形式で保存するProsedure

Sub DownloadSearchedMailItem(MyMailItm As Object)
Dim myItem As MailItem
Dim NS As NameSpace
Dim objOutlook
Dim olIns As Inspector
Dim EX As Explorer
Dim objFol As Outlook.Folder
Dim FSO As New FileSystemObject
Dim tempFol As Object, strtempFOl As String
Dim strfile As String, strSender As String, Dt As Date
'Dim ADOS As New ADODB.Stream
Dim strMal()
Dim adreadall As String
Dim objTempFile As Object, strBase
'Dim wDoc As Word.Document
Dim StrSPFolder As String, cnt As Integer
Dim oSFol As Object, RSChr As String, strSub As String
Dim objOlFolder As Outlook.Folder
Dim Ar As Variant
Dim ArR() As Variant, iArR As Long, strRecip As String
Dim Reg As RegExp
Const SendFolderName As String = "送信済みアイテム"
Const ReceiveFolderName As String = "受信トレイ"
Const strSendChr = "S"
Const strReceiveChr = "R"
Set myItem = MyMailItm
With CreateObject("WScript.Shell")
StrSPFolder = .SpecialFolders("mydocuments")
Set oSFol = FSO.GetFolder(StrSPFolder)
End With
'Set objOutlook = CreateObject("Outlook.Application")
Set NS = Application.GetNamespace("MAPI")
Set olIns = myItem.GetInspector: DoEvents
Ar = Split(olIns.CurrentItem.Parent.FullFolderPath, "\"): DoEvents
cnt = 0: RSChr = ""
For cnt = UBound(Ar) To LBound(Ar) Step -1
If Ar(cnt) = SendFolderName Or Ar(cnt) = "Sent Items" Or Ar(cnt) = "送信トレイ" Then
RSChr = strSendChr: Exit For
ElseIf Ar(cnt) = ReceiveFolderName Or Ar(cnt) = "Inbox" Or olIns.CurrentItem.Parent.FullFolderPath = ReceiveFolderName Then
RSChr = strReceiveChr: Exit For
End If
Next
If RSChr = "" Then Exit Sub

Dt = myItem.ReceivedTime
strSub = replaceNGchar("件名_" & Left(myItem.Subject, 15) & "_")
strfile = ""
'////sstrSenderの定義
strSender = ""
'////送信の場合
If RSChr = strSendChr Then
For iArR = 1 To myItem.Recipients.Count
ReDim Preserve ArR(1 To iArR)
strRecip = CStr(myItem.Recipients.Item(iArR))
Set Reg = New RegExp
Reg.Global = True
Reg.IgnoreCase = False
Reg.Pattern = "（.+?.）$"
strRecip = Reg.Replace(strRecip, " ")
ArR(iArR) = Replace(strRecip, " ", "", 1, -1, vbTextCompare)
Set Reg = Nothing
Next
If UBound(ArR) = 1 Then strSender = Replace(CStr(ArR(1)), "'", "", 1) & "_全" & "1名" Else strSender = Replace(CStr(ArR(1)), "'", "", 1) & "他" & UBound(ArR) - 1 & "名"
'////受信の場合
ElseIf RSChr = strReceiveChr Then
Set Reg = New RegExp
strSender = Mid(CStr(myItem.Sender), 1, 10)
Reg.Global = True
Reg.IgnoreCase = False
Reg.Pattern = "（.+?.）$"
strSender = Replace(Replace(Reg.Replace(strSender, " "), " ", ""), "　", "")
Set Reg = Nothing
End If

'////ファイルの重複を回避
strBase = StrSPFolder & "\" & Format(CDate(Dt), "YYYYMMDDhhmmss") & RSChr & strSender & "_" & strSub
strfile = strBase & ".msg"
If FSO.FileExists(strfile) = True Then
i = 1
Do
If FSO.FileExists(strBase & "(" & i & ")" & ".msg") = False Then
strfile = strBase & "(" & i & ")" & ".msg"
myItem.SaveAs strBase & "(" & i & ")" & ".msg", olMSGUnicode
Exit Do
End If
i = i + 1
Loop
Else
myItem.SaveAs strfile, olMSGUnicode
End If
End Sub

'[OUTLOOK VBA クィックアクセスツールバー用 選択したメールをmsg形式で保存する](http://qiita.com/Q11Q/items/30f4234b9b191cf17618)をすでにコピペしている場合、以下は重複するので不要です
Public Function replaceNGchar(ByVal sourceStr As String, _
Optional ByVal replaceChar As String = "") As String

Dim tempStr As String

tempStr = sourceStr
tempStr = Replace(tempStr, "\", replaceChar)
tempStr = Replace(tempStr, "/", replaceChar)
tempStr = Replace(tempStr, ":", replaceChar)
tempStr = Replace(tempStr, "*", replaceChar)
tempStr = Replace(tempStr, "?", replaceChar)
tempStr = Replace(tempStr, """", replaceChar)
tempStr = Replace(tempStr, "<", replaceChar)
tempStr = Replace(tempStr, ">", replaceChar)
tempStr = Replace(tempStr, "|", replaceChar)
tempStr = Replace(tempStr, "[", replaceChar)
tempStr = Replace(tempStr, "]", replaceChar)

replaceNGchar = tempStr
End Function

##AdvancedSearch
###AdvancedSearchのポイント

  • Inbox Sent itemsを検索するときは最終更新日をキーワードにすると広く検索できる
  • ただしアイテム数が多いと非常に重く、いつまでたっても終わらないので、文字列で検索をかけるのはアイテム数が少ない場合にする方がよいと思う
    検索条件は日付のみ、又はタイトルのみになるがメールだけでなく同じアカウントの受信、送信、予定表など一括して検索できるのが強み。また検索フォルダとして残る。
  • しかし〇日～〇日という期間の指定はいまのところ失敗する。
  • 検索フォルダを作成して保存する場合タイプスタンプで名前を作るとユニークで重複がない
  • もしくはDo loopでデータをイミディエイトに吐き出せる。
  • イミディエイトに出力させるばあいで、タイトルで絞り込みたいときはこのDoLOOPにIf文を仕掛けるといいのかもしれない
  • UTCにするために空のメールアイテムを作り、そこにプロパティアクセスオブジェクトを作り、それでUTCに変換している。
  • 'Establish filterはOutlook2010以降は入れなくてよいかもしれない。（クィック検索が無効にならないため）
  • propタグはある程度定数化できるが、DAV:...を定数化すると失敗した。全部定数化すると失敗する
  • Scopeのフォルダ名は日本語でも英語でもよい
  • While wendで検索が終わるのを待たなければならない。これも処理が遅くなる原因

###Scopeのフォルダ名
英語でも日本語でもよい
"'Inbox','sent items','tasks'"
"'受信トレイ','送信済みアイテム','タスク'"
この3つはどちらでも動く。
##AdvancedSearchのフィルターについて
###動くもの
最終更新日付のみ
`sFil = Chr(34) & "DAV:getlastmodified" & Chr(34) & " > '" & Format$(datStartUTC, "General Date") & "'"~

としておき
Do loopで 'If oRow("Subject") Like "*ongaku*" Then
のようにタイトルにIFで絞り込むというもの。
しかし厳密にいうとサーチで絞り込んだものではない。

###動くけどいまいちなもの（なんか遅かったりうまくフィルタしていない）
最終更新日付とタイトル（遅い）

If Application.Session.DefaultStore.IsInstantSearchEnabled Then
        sFil = Chr(34) & "urn:schemas:httpmail:subject" _
        & Chr(34) & " ci_phrasematch 'Office' And " & Chr(34) & "DAV:getlastmodified" & Chr(34) & " >'" & Format\$(datStartUTC, "General Date") & "'"
Else
        sFil = Chr(34) & "urn:schemas:httpmail:subject" _
        & Chr(34) & " like '%Office%' And " & Chr(34) & "DAV:getlastmodified" & Chr(34) & " >'" & Format\$(datStartUTC, "General Date") & "'"
End If

###動かないもの
sFil = Chr(34) & "DAV:getlastmodified" & Chr(34) & " >'" & Format$(datStartUTC, "General Date") & "' AND 　" & Chr(34) & "DAV:GetLastmodified" & Chr(34) & "<'" & Format$(#4/9/2017 12:00:00 PM#, "General Date") & "'"

###動くけど値を拾わないもの
sFil = AddQuotes("DAV:GetLastmodified") _
& " > '" & datStartUTC & "' AND " _
& AddQuotes("DAV:GetLastmodified") _
& " < '" & datEndUTC & "'"
絞り込み検索をやっても効かない
sFil = Chr(34) & "DAV:getlastmodified" & Chr(34) & " >'" & Format$(datStartUTC, "General Date") & "' AND " & Chr(34) & "DAV:GetLastmodified" & Chr(34) & "<'" & Format$(#4/9/2017 12:00:00 PM#, "General Date") & "'"

###動くけど意味がないもの
sFil = Chr(34) & "DAV:getlastmodified" & Chr(34) & " >'" & Format$(datStartUTC, "General Date") & "' OR " & Chr(34) & "DAV:GetLastmodified" & Chr(34) & "<'" & Format$(#4/9/2017 12:00:00 PM#, "General Date") & "'"
ORだと動くがこれは日付を設定していないので意味がない。

タイトルで検索するもの
　タイトル検索は終わらないので不可。

##パターンその1
最終更新日のみで検索を行い、最後出来上がったテーブルで、読みだす際に絞り込むというもの
どちらのパターンももタグにtestと入れているので、イヴェントプロシージャに入り、整合性を保つようになっている。
Stopの際エラートラップも行うが、たまにとまりません。止まらない場合はCtrl+Breakでとめてください。
MSは書いていないけどサーチが失敗すると、サーチオブジェクト自体ができないので、If Not Object is Nothing Thenが必要です。

Sub StartAdvSerch()
blnSearchComp = False
blnSearchStop = False
Dim oMail As MailItem
Dim oPA As PropertyAccessor
Dim datStartUTC As Date
Dim datEndUTC As Date

Dim colItems As Outlook.Items
Dim sFil As String
Const SchemaPropTag As String = _
    "http://schemas.microsoft.com/mapi/proptag/"
Const DavScmLastMod As String = "DAV:GetLastmodified" 'Do not Use. It does not work.
Const UrnScmSub As String = "urn:schemas:httpmail:subject"
Set colItems = _
Application.Session.GetDefaultFolder(olFolderInbox).Items
Set oMail = Application.CreateItem(olMailItem)
Set oPA = oMail.PropertyAccessor
datStartUTC = oPA.LocalTimeToUTC(CDate(#2/4/2017 8:00:00 AM#))
datEndUTC = oPA.LocalTimeToUTC(CDate(#4/9/2017 8:15:00 AM#))
'Establish filter
sFil = Chr(34) & "DAV:getlastmodified" & Chr(34) & " > '" & Format$(datStartUTC, "General Date") & "'"
SearchForSubject strFilter:=sFil, _
                     strScope:="'inbox','sent items','tasks'", blnSubfolderMatch:=False, strTag:="Test"
End Sub

Sub SearchForSubject(ByVal strFilter As String, ByVal strScope As String, ByVal blnSubfolderMatch As Boolean, ByVal strTag As String)
'複数のフォルダ内で特定の件名を持つ
'すべてのアイテムを検索します。
Dim objSch As Outlook.Search
Dim olRsts As Outlook.Results
Dim stRFolderName
Dim olSchTable As Table
Dim oRow As Outlook.Row
Dim cnt As Long
On Error GoTo olSearchErr_Handle
Debug.Print "Filter:", strFilter
    Set objSch = Application.AdvancedSearch(strScope, strFilter, blnSubfolderMatch, strTag)
While blnSearchComp = False
        DoEvents
Wend
Debug.Print "objSch.Results.Count", objSch.Results.Count
If objSch.Results.Count > 0 Then Set olRsts = objSch.Results Else Exit Sub
stRFolderName = Format(Now, "YYYYMMDDHHmmss") & "Sch"
Debug.Print objSch.Filter
Set olSchTable = objSch.GetTable
cnt = 0
Do Until (olSchTable.EndOfTable)
If cnt > 50 Then Exit Do Else cnt = cnt + 1: Debug.Print cnt
Set oRow = olSchTable.GetNextRow()
If oRow("Subject") Like "*ongaku*" Then
 Debug.Print (oRow("EntryID"))
 Debug.Print (oRow("Subject"))
 Debug.Print (oRow("CreationTime"))
 Debug.Print (oRow("LastModificationTime"))
 Debug.Print (oRow("MessageClass"))
End If
Loop

’objSch.Save (stRFolderName): DoEvents
Debug.Print "End"

Exit Sub

olSearchErr_Handle:
If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description, Err.Source
If Not objSch Is Nothing Then
objSch.Stop
While blnSearchStop = False
        DoEvents
Wend
Exit Sub
Else
Debug.Print "search object doesn't make"
Exit Sub
End If
End Sub

Public Function AddQuotes(ByVal SchemaName As String) As String
    On Error Resume Next
    AddQuotes = Chr(34) & SchemaName & Chr(34)
End Function

##パターンその2(If文のパターン)
最終更新日2017/2/4からタイトルにongaku をふくむもの
’objSch.Save (stRFolderName): DoEventsのコメントを外すと、検索フォルダを作成する。
なお複数のメールアカウントを開いている場合、現在開いているアカウントの検索を行う。
ただし、アイテム数が多いと重くなる。
タスクを含むことはできるが、日付を短くしないと固まってしまう。

Sub StartAdvSerch()
blnSearchComp = False
blnSearchStop = False
Dim oMail As MailItem
Dim oPA As PropertyAccessor
Dim datStartUTC As Date
Dim datEndUTC As Date

Dim colItems As Outlook.Items
Dim sFil As String
Const SchemaPropTag As String = _
    "http://schemas.microsoft.com/mapi/proptag/"
Const DavScmLastMod As String = "DAV:GetLastmodified" 'Do not Use. It does not work.
Const UrnScmSub As String = "urn:schemas:httpmail:subject"
Set colItems = _
Application.Session.GetDefaultFolder(olFolderInbox).Items
Set oMail = Application.CreateItem(olMailItem)
Set oPA = oMail.PropertyAccessor
datStartUTC = oPA.LocalTimeToUTC(CDate(#2/4/2017 8:00:00 AM#))
datEndUTC = oPA.LocalTimeToUTC(CDate(#4/9/2017 8:15:00 AM#))
'Establish filter
    If Application.Session.DefaultStore.IsInstantSearchEnabled Then
        sFil = Chr(34) & "urn:schemas:httpmail:subject" _
        & Chr(34) & " ci_phrasematch 'ongaku' And " & Chr(34) & "DAV:getlastmodified" & Chr(34) & " >'" & Format$(datStartUTC, "General Date") & "'"
    Else
        sFil = Chr(34) & "urn:schemas:httpmail:subject" _
        & Chr(34) & " like '%ongaku%' And " & Chr(34) & "DAV:getlastmodified" & Chr(34) & " >'" & Format$(datStartUTC, "General Date") & "'"
    End If
SearchForSubject strFilter:=sFil, _
                     strScope:="'inbox','sent items','tasks'", blnSubfolderMatch:=False, strTag:="Test"
End Sub

Sub SearchForSubject(ByVal strFilter As String, ByVal strScope As String, ByVal blnSubfolderMatch As Boolean, ByVal strTag As String)
'複数のフォルダ内で特定の件名を持つ
'すべてのアイテムを検索します。
Dim objSch As Outlook.Search
Dim olRsts As Outlook.Results
Dim stRFolderName
Dim olSchTable As Table
Dim oRow As Outlook.Row
Dim cnt As Long
On Error GoTo olSearchErr_Handle
Debug.Print "Filter:", strFilter
    Set objSch = Application.AdvancedSearch(strScope, strFilter, blnSubfolderMatch, strTag)
While blnSearchComp = False
        DoEvents
Wend
Debug.Print "objSch.Results.Count", objSch.Results.Count
If objSch.Results.Count > 0 Then Set olRsts = objSch.Results Else Exit Sub
stRFolderName = Format(Now, "YYYYMMDDHHmmss") & "Sch"
Debug.Print objSch.Filter
Set olSchTable = objSch.GetTable
cnt = 0
Do Until (olSchTable.EndOfTable)
If cnt > 50 Then Exit Do Else cnt = cnt + 1: Debug.Print cnt
Set oRow = olSchTable.GetNextRow()
If oRow("Subject") Like "*ongaku*" Then
 Debug.Print (oRow("EntryID"))
 Debug.Print (oRow("Subject"))
 Debug.Print (oRow("CreationTime"))
 Debug.Print (oRow("LastModificationTime"))
 Debug.Print (oRow("MessageClass"))
End If
Loop

’objSch.Save (stRFolderName): DoEvents
Debug.Print "End"

Exit Sub

olSearchErr_Handle:
If Not objSch Is Nothing Then
objSch.Stop
Else
If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description, Err.Source
Exit Sub
End If
While blnSearchStop = False
        DoEvents
Wend
Exit Sub
End Sub



Public Function AddQuotes(ByVal SchemaName As String) As String
    On Error Resume Next
    AddQuotes = Chr(34) & SchemaName & Chr(34)
End Function

##その３ StackOverflowのパターン
Items.Restrict
で出来上がったResultコレクションにRestrictをかける
この場合はUTCに変換しなくてよい
しかし受信フォルダのみなどフォルダは１つだけに絞られる。
ただしその分早く、安定している。
ただし、検索結果resultsの変数宣言はObjectでないとバグを起こす。
As Outlook.Results はバグになる。という注意点がある。

Sub ItemsRestrictTwiceSearch()
    Dim oOlAp As Outlook.Application
    Dim oOlns As Outlook.NameSpace
    Dim oOlInb As Object　'Do not Outlook.Folder
    Dim oOlResults As Object 'Do not Outlook.Results
    Dim oOlItm As Object 'Do not Outlook.Results
    
    Dim oOlSubjectResults  As Object
    Dim strFilter As String
    Dim i As Long
    Dim x As Long
    'You can only have a single instance of Outlook, so if it's already open
    'this will be the same as GetObject, otherwise it will open Outlook.
    Set oOlAp = CreateObject("Outlook.Application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

    'No point searching the whole Inbox - just since yesterday.
    Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>'" & Format(#2/4/2017#, "DDDDD HH:NN") & "'")

    strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%ongaku%'"

    Set oOlSubjectResults = oOlResults.Restrict(strFilter)

    If oOlSubjectResults.Count = 0 Then
        Debug.Print "No emails found with applicable subject"
    Else
        'If you have more than a single attachment they'll all overwrite each other.
        'x will update the filename.
        x = 1

        For i = 1 To oOlSubjectResults.Count
            Set oOlItm = oOlSubjectResults(i)
                With oOlItm
                Debug.Print .EntryID
                Debug.Print .Subject
                Debug.Print .CreationTime
                Debug.Print .LastModificationTime
                Debug.Print .MessageClass
                End With


        Next i
    End If

ExitRoutine:
    Set oOlAp = Nothing
    Set oOlns = Nothing
    Set oOlInb = Nothing

    Set oOlResults = Nothing
    Set oOlSubjectResults = Nothing

End Sub

##その4 Stack版をさらに改造してStoreFolderで受信フォルダのタイトル、日付、送信者名またはアドレスで検索
検索開始日と終了日
メールアドレス、または保存先の受信フォルダの
件名の一部と送信者名（アドレスも名前も）
検索して返します。
Item.Restricは日付が範囲にできるので便利です。
'if .MessaeClass="IPM.Note" Then
'Call DownloadSearchedMailItem(oOitm)
'End if
上記の準備をしていると、この3行をコメントアウトから戻せば、メールとして保存します。

Sub ItemsRestrictTplStoreSearch()
    Const StoreName As String = "name@domain" 'メールアドレス、オフラインフォルダならなら通常は保存先
    '変数の宣言と検索条件の設定
      '検索開始日と終了日
    Dim STDt As Date, EnDt As Date: STDt = CDate(Format(DateAdd("D", -10, Now), "YYYY/MM/DD")): EnDt = CDate(Format(Now, "YYYY/MM/DD"))
     '件名の一部
    Dim sSUb As String: sSUb = "日経"
    '送信者
    Dim sAdr As String: ' sAdr = "nikkei"
    Dim oOlAp As Outlook.Application
    Dim oOlns As Outlook.NameSpace
    Dim oOlInb As Object  'Do not Outlook.Folder
    Dim oOlResults As Object 'Do not Outlook.Results
    Dim oOlItm As Object 'Do not Outlook.Results
    Dim oOlStores As Object, oOlStore As Object
    Dim oOlSubjectResults  As Object, oOlRoot As Object, oOlFolds As Object
    Dim strFilter As String
    Dim i As Long
    Dim oOlStoreFolders As Object
    Dim MyItem as MailIem

    Set oOlAp = CreateObject("Outlook.Application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlStores = oOlns.Stores
    Set oOlStore = oOlStores(StoreName)
    Set oOlRoot = oOlStore.GetRootFolder
    Set oOlFolds = oOlRoot.Folders
    Set oOlInb = oOlFolds("受信トレイ")
    Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>='" & Format(STDt, "DDDDD HH:NN") & "' AND " & "[ReceivedTime]<='" & Format(EnDt, "YYYY/MM/DD") & "'")
    strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & sSUb & "%'"

    Set oOlSubjectResults = oOlResults.Restrict(strFilter)
If sAdr <> "" Then GoTo AddressSearchPlus Else GoTo NormalDoubleSearch
AddressSearchPlus:
    If oOlSubjectResults.Count = 0 Then
        Debug.Print "No emails found with applicable subject"
    Else

        For i = 1 To oOlSubjectResults.Count
            Set oOlItm = oOlSubjectResults(i)
                With oOlItm
                If .SenderEmailAddress Like "*" & sAdr & "*" Or .Sender Like "*" & sAdr & "*" Then
                Debug.Print .EntryID
                Debug.Print .Subject
                Debug.Print .CreationTime
                Debug.Print .LastModificationTime
                Debug.Print .MessageClass
                Debug.Print .ReceivedTime
                Debug.Print .SenderName
                  'if .MessaeClass="IPM.Note" Then
                    'Call DownloadSearchedMailItem(oOitm)
                  'End if
                End If
                End With
        Next i
    End If
GoTo ExitRoutine
Exit Sub
NormalDoubleSearch:
    If oOlSubjectResults.Count = 0 Then
        Debug.Print "No emails found with applicable subject"
    Else

        For i = 1 To oOlSubjectResults.Count
            Set oOlItm = oOlSubjectResults(i)
                With oOlItm
                Debug.Print .EntryID
                Debug.Print .Subject
                Debug.Print .CreationTime
                Debug.Print .LastModificationTime
                Debug.Print .MessageClass
                Debug.Print .ReceivedTime
                Debug.Print .SenderName
                  'if .MessaeClass="IPM.Note" Then
                    'Call DownloadSearchedMailItem(oOitm)
                  'End if
                End With
        Next i
    End If
GoTo ExitRoutine
Exit Sub

ExitRoutine:
    Set oOlAp = Nothing
    Set oOlns = Nothing
    Set oOlInb = Nothing
    Set oOlResults = Nothing
    Set oOlSubjectResults = Nothing

End Sub

##パターンその5
###送信済みアイテムを、送信日、タイトル、宛先のアドレスで検索する
Item.resricを使う。ただし、タイトル、宛先がわからないときは空白でも検索できる。
'if .MessaeClass="IPM.Note" Then
'Call DownloadSearchedMailItem(oOitm)
'End if
上記の準備をしていると、この3行をコメントアウトから戻せば、メールとして保存します。

Sub ItemsRestrictTplStoreSearchSndSimple()
    Const StoreName As String = "name@domain" 'メールアドレス、オフラインフォルダならなら通常は保存先
    '変数の宣言と検索条件の設定
      '検索開始日と終了日
    Dim STDt As Date, EnDt As Date: STDt = CDate(Format(DateAdd("D", -40, Now), "YYYY/MM/DD")): EnDt = CDate(Format(Now, "YYYY/MM/DD"))
     '件名の一部 なくてもよい
    Dim sSUb As String: sSUb = "Fire"
    '送信者
    Dim sAdr As String: sAdr = ""
    Dim oOlAp As Outlook.Application
    Dim oOlns As Outlook.NameSpace
    Dim oOlInb As Object  'Do not Outlook.Folder
    Dim oOlResults As Object 'Do not Outlook.Results
    Dim oOlItm As Object 'Do not Outlook.Results
    Dim oOlStores As Object, oOlStore As Object
    Dim oOlSubjectResults  As Object, oOlRoot As Object, oOlFolds As Object
    Dim strFilter As String
    Dim i As Long
    Dim oOlStoreFolders As Object

    Set oOlAp = CreateObject("Outlook.Application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlStores = oOlns.Stores
    Set oOlStore = oOlStores(StoreName)
    Set oOlRoot = oOlStore.GetRootFolder
    Set oOlFolds = oOlRoot.Folders
    Set oOlInb = oOlFolds("送信済みアイテム")
    Set oOlResults = oOlInb.Items.Restrict("[SentOn]>='" & Format(STDt, "DDDDD HH:NN") & "' AND " & "[SentOn]<='" & Format(EnDt, "YYYY/MM/DD") & "'")
    If sSUb <> "" Then
    strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & sSUb & "%'"
    Set oOlSubjectResults = oOlResults.Restrict(strFilter)
    Else
    Set oOlSubjectResults = oOlResults
    End If
If sAdr <> "" Then GoTo AddressSearchPlus Else GoTo NormalDoubleSearch
AddressSearchPlus:
    If oOlSubjectResults.Count = 0 Then
        Debug.Print "No emails found with applicable subject"
    Else

        For i = 1 To oOlSubjectResults.Count
            Set oOlItm = oOlSubjectResults(i)
                With oOlItm
                If .SenderEmailAddress Like "*" & sAdr & "*" Or .Sender Like "*" & sAdr & "*" Then
                Debug.Print .EntryID
                Debug.Print .Subject
                Debug.Print .CreationTime
                Debug.Print .LastModificationTime
                Debug.Print .MessageClass
                Debug.Print .ReceivedTime
                Debug.Print .SenderName
                  'if .MessaeClass="IPM.Note" Then
                    'Call DownloadSearchedMailItem(oOitm)
                  'End if
                End If
                End With
        Next i
    End If
GoTo ExitRoutine
Exit Sub
NormalDoubleSearch:
    If oOlSubjectResults.Count = 0 Then
        Debug.Print "No emails found with applicable subject"
    Else

        For i = 1 To oOlSubjectResults.Count
            Set oOlItm = oOlSubjectResults(i)
                With oOlItm
                Debug.Print .EntryID
                Debug.Print .Subject
                Debug.Print .CreationTime
                Debug.Print .LastModificationTime
                Debug.Print .MessageClass
                Debug.Print .ReceivedTime
                Debug.Print .SenderName
                  'if .MessaeClass="IPM.Note" Then
                    'Call DownloadSearchedMailItem(oOitm)
                  'End if
                End With
        Next i
    End If
GoTo ExitRoutine
Exit Sub

ExitRoutine:
    Set oOlAp = Nothing
    Set oOlns = Nothing
    Set oOlInb = Nothing

    Set oOlResults = Nothing
    Set oOlSubjectResults = Nothing

End Sub

##パターンその6 Create an Outlook 2010 Search Folder using VBAを日本語向けに改造したもの

###Storeでアカウントを決めて、受信メールに対して、メールアドレスを複数の条件で検索してサーチフォルダを作る。サブフォルダまで検索する
このときPrSenderというのを使うのが他と違う。
また日本語のOutlookはフォルダ名が違うのと頭がドメイン抜きではない。
原文はmy@domain.nationならその受信フォルダは \my\inboxとしている。
しかし、日本語のOl2013以降は \my@domain.naition\受信トレイ となる
これはOutlook2010との違いなのか不明だ。
なお、実際に使用する場合にはFilterのところはサンプルのままではなく、調べたい送信したアドレスに変えないと、重すぎて止まらないため、Ctrl+BreaKで止めざるを得ない。
メールの検索には実用性に欠けているが、このPR系の検索方法は主に文字列のプロパティで、タスクアイテム、カレンダーアイテムなどに向いているようだ。
　また送信済みアイテムが少ない時、送信先を指定するのも悪くないと思う
　これでもやはり日付は使えない。
　原文ではサーチフォルダは既存のものがないかチェックするが、こちらは現在時刻名でフォルダを作るので常にユニークのはずなため省略している。

 Sub AddNotInternalSearchFolder()
 'イヴェントプロシージャ用のBoolean変数をFalseにする
 blnSearchComp = False
 blnSearchStop = False
 Dim filter As String
 Dim Ar
 'メールアドレス、または保存先
 Const cnStoreNm = "my@domain.naition" 'または "保存先"
 Const cnJOlInbx = "受信トレイ" '英語だとInbox。これはフォルダーパスが原因
 Const cnJOlSent = "送信済みアイテム" '英語だとSentMail?。これはフォルダーパスが原因
 Const PR_SENDER_EMAIL_ADDRESS_W As String = "http://schemas.microsoft.com/mapi/proptag/0x0C1F001F"
      
 
 Dim strTest
 strTest = Replace(cnStoreNm, "@", "", 1, -1, vbTextCompare)
 'メールアドレスが保存先だと@を消すと異なる
 '
 If strTest <> cnStoreNm Then
 Ar = Split(Application.Session.Stores("my@domain.nation").GetRootFolder.Folders(cnJOlInbx).folderPath, "@")
 Else
 ReDim Preserve Ar(0 To 1)
 Ar(0) = cnStoreNm
 End If
 'ここがすごい。PR Senderを使い、Likeを使い%ワイルドカードを使い、さらにAもBも含まないという集合をフィルタで造っている
    filter = "NOT (" & PR_SENDER_EMAIL_ADDRESS_W & " LIKE '%@domain.nation%')" & _
             "AND NOT (" & PR_SENDER_EMAIL_ADDRESS_W & " LIKE '%@domain.nation%')"
    
 Stop
    'Call CreateSearchFolder(cnStoreNm, "'" & Replace(Ar(0), "\\", "\", 1, 1, vbTextCompre) & "\" & cnJOlInbx & "'", filter, "test")
     Call CreateSearchFolder(cnStoreNm, "'\" & cnStoreNm & "\" & cnJOlInbx & "'", filter, "test")
End Sub
Sub CreateSearchFolder(storeName As String, _
                       folderPath As String, _
                       filter As String, _
                       strTag As String)

Dim objSearch As Search
On Error GoTo olSearchErr_Handle
        Set objSearch = Application.AdvancedSearch(folderPath, _
                                                   filter, _
                                                   True, _
                                                   strTag)
While blnSearchComp = False
DoEvents
Wend
Stop
Dim folderToCreate As String
folderToCreate = Format(Now, "YYYYMMDDHHmmSS") & "Search"
objSearch.Save (folderToCreate)
MsgBox "Done!"
Exit Sub

olSearchErr_Handle:
If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description, Err.Source
If Not objSch Is Nothing Then
objSch.Stop
While blnSearchStop = False
        DoEvents
Wend
Exit Sub
Else
Debug.Print "search object doesn't make"
Exit Sub
End If
End Sub

#メール以外
##履歴項目　Jounaliem
###サンプルその１（リンクのみにしたかった）
JournalItem.LastModificationTime Property (Outlook) - Github
あ、履歴項目自体は、Outlook2013以降は自動で動きませんが、VBScriptでオフィスファイル位は登録できるようにしました。リンク 偉大なOutlook研究所と比較すると、ファイル名をURIにして登録してあるので、警告は出ますが、ジャンプはできます。

さすがGithubだ。。。と思ったら違う、節子、これ履歴やないコンタクトアイテムや！
Set myContacts = myNamespace.GetDefaultFolder(olFolderContacts).Items
しかしこのSample2016年にアップしているわりにスタートが2003年なんてどんだけ古いんや・・・
というわけで、直近１週間にしました。
ただしOffice 2013以降は自動で履歴は更新されません。したがって、LastUdateも自動では更新されないので、これで100%検索ができるわけではありません。

Public Sub SearchJounalRestrictWithLstUpDt()
  Dim myNamespace As Outlook.NameSpace
  Dim myContacts As Outlook.Items
  Dim myItems As Outlook.Items
  Dim myItem As Object
 
 Set myNamespace = Application.GetNamespace("MAPI")
 
 Set myContacts = myNamespace.GetDefaultFolder(olFolderJournal).Items
 
 'Set myItems = myContacts.Restrict("[LastModificationTime] > '01/1/2003'")
  Set myItems = myContacts.Restrict("[LastModificationTime] > '" & Format(DateAdd("D", -7, Now), "YYYY/MM/DD") & "'")
For Each myItem In myItems
If (myItem.Class = olJournal) Then
 Debug.Print myItem.Subject & ";" & myItem.LastModificationTime
End If
Next
End Sub
3
3
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
3
3

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?