回答ありがとうございます。
このような感じでしょうか。
このスクリプトではエラーが出てしまいました。
Const olMSG = 3
sBasePath = !ファイル保存先!
searchFolder = !検索対象フォルダ!
splitChr = !区切り文字|\,/,#,$,%!
sSUb = !件名!
sTxt = !本文!
sFrom = !差出人!
sTo = !宛先!
sRecvDate = !受信日時|,昨日,今日,過去7日以内,先週,今週,先月,今月!
sSendDate = !送信日時|,昨日,今日,過去7日以内,先週,今週,先月,今月!
sAttach = !添付ファイル有無|,有り,無し!
'sortType = !ソート対象|,受信日付,送信日付!
'sortMode = !ソート順|,昇順,降順!
saveMax = !保存上限件数!
SetUMSVariable $検索件数$, 0
SetUMSVariable $保存件数$, 0
Dim oApp
Dim oSelection
Dim oMail
Dim oFS
Dim sf
Call CheckParameter(sBasePath,searchFolder,saveMax)
sf = MakeRistrictFilter(sSUb, sTxt, sFrom, sTo, sSendDate, sRecvDate, sAttach)
Call execSaveMails(searchFolder, splitChr, sf, sBasePath)
'--------------------------------------------------------------------
'パラメタの有効性確認
'--------------------------------------------------------------------
Sub CheckParameter(sBasePath,searchFolder,saveMax)
If sBasePath = "" Then
Err.Raise 1, "", "ファイル保存先を入力してください。"
WScript.Quit()
End If
If searchFolder = "" Then
Err.Raise 1, "", "検索対象フォルダを入力してください。"
WScript.Quit()
End If
If saveMax = "" Then
Err.Raise 1, "", "保存上限件数を入力してください。"
WScript.Quit()
End If
End Sub
'--------------------------------------------------------------------
'メール保存メイン実行部
'--------------------------------------------------------------------
Sub execSaveMails(searchFolder, splitChr, sf, sBasePath)
Dim oApp
Set oApp = Nothing
Dim oOlns 'As Outlook.NameSpace
Dim oOlInb 'As Object 'Do not Outlook.Folder
Dim oOlStores 'As Object
Dim oOlStore 'As Object
Dim oOlFold 'As Object
On Error Resume Next
'起動済みのOutlookをクラス名を指定して取得
Set oApp = GetObject(, "Outlook.Application")
On Error GoTo 0
'oAppがNothingなら
If oApp Is Nothing Then
Err.Raise 1, "", "Outlookが起動されていません。"
'WScript.Quit()
Else
Dim myOlExp
Set myOlExp = oApp.ActiveExplorer
If myOlExp Is Nothing Then
Err.Raise 1, "", "Outlookが起動されていません。"
WScript.Quit()
Else
'検索対象フォルダに移動
Set oOlns = oApp.GetNamespace("MAPI")
arrayStrings = Split(searchFolder, splitChr)
Set oOlStores = oOlns.Stores
Set oOlStore = oOlStores(arrayStrings(0))
Set oOlFold = oOlStore.GetRootFolder
For i = LBound(arrayStrings) + 1 To UBound(arrayStrings)
Set oOlFold = oOlFold.Folders(arrayStrings(i))
Next
End If
End If
'条件無しはフォルダ内全アイテム、条件有りはフォルダ内アイテムフィルタ
If sf = "" Then
Set oOlSubjectResults = oOlFold.Items
Else
Set oOlSubjectResults = oOlFold.Items.Restrict(sf)
End If
SetUMSVariable $検索件数$, oOlSubjectResults.Count
SetUMSVariable $保存件数$, oOlSubjectResults.Count
If oOlSubjectResults.Count > 0 Then
Set oFS = WScript.CreateObject("Scripting.FilesystemObject")
If oOlSubjectResults.Count > Cint(saveMax) Then
SetUMSVariable $保存件数$, 0
Else
Dim count
count = 0
For i = 1 To oOlSubjectResults.Count
If oOlSubjectResults(i).Class = 43 Then
'保存先作成
sSavePath = MakeSavePath(oFS, sBasePath, oOlSubjectResults(i).receivedTime,
oOlSubjectResults(i))
'メールと添付ファイル保存
Call SaveMailAndFile(oFS, oOlSubjectResults(i), sSavePath)
count = count +1
End If
Next
SetUMSVariable $保存件数$, count
End If
End If
End Sub
'--------------------------------------------------------------------
'日付フィルタ整形
'--------------------------------------------------------------------
Function ChangeDateUrnString(DateStr)
Select Case DateStr
Case "昨日"
ChangeDateUrn = "yesterday"
Case "今日"
ChangeDateUrn = "today"
Case "過去7日以内"
ChangeDateUrn = "last7days"
Case "先週"
ChangeDateUrn = "lastweek"
Case "今週"
ChangeDateUrn = "thisweek"
Case "先月"
ChangeDateUrn = "lastmonth"
Case "今月"
ChangeDateUrn = "thismonth"
Case Else
ChangeDateUrn = ""
End Select
ChangeDateUrnString = ChangeDateUrn
End Function
'--------------------------------------------------------------------
'フィルタ文字列生成
'--------------------------------------------------------------------
Function MakeRistrictFilter(sSUb, sTxt, sFrom, sTo, sSendDate, sRecvDate, sAttac)
Dim strFilter
strFilter = ""
'フィルタを組み上げ。空でなければフィルタ化する。設定済みフィルタがあればANDで追加する
'件名
If sSUb <> "" Then
strFilter = strFilter & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & sSUb & "%'"
End If
'本文
If sTxt <> "" Then
If Len(strFilter) > 0 Then
strFilter = strFilter & " AND "
End If
strFilter = strFilter & Chr(34) & "urn:schemas:httpmail:textdescription" & Chr(34) & " like '%" & sTxt & "%'"
End If
'差出人
If sFrom <> "" Then
If Len(strFilter) > 0 Then
strFilter = strFilter & " AND "
End If
' strFilter = strFilter & Chr(34) & "urn:schemas:httpmail:fromname" & Chr(34) & " like '%" & sFrom & "%'"
strFilter = strFilter & "(" & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0065001f" & Chr(34) & " CI_STARTSWITH '" & sFrom & "' OR " _
& Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0042001f" & Chr(34) & " CI_STARTSWITH '" & sFrom & "')"
End If
'宛先
If sTo <> "" Then
If Len(strFilter) > 0 Then
strFilter = strFilter & " AND "
End If
' strFilter = strFilter & Chr(34) & "urn:schemas:httpmail:fromname" & Chr(34) & " like '%" & sTo & "%'"
strFilter = strFilter & "(" & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0e04001f" & Chr(34) & " CI_STARTSWITH '" & sTo & "' OR " _
& Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0e03001f" & Chr(34) & " CI_STARTSWITH '" & sTo & "')"
End If
'送信日時
If sSendDate <> "" Then
dateUrn = ChangeDateUrnString(sSendDate)
If dateUrn <> "" Then
If Len(strFilter) > 0 Then
strFilter = strFilter & " AND "
End If
strFilter = strFilter & "%" & dateUrn & "(""urn:schemas:httpmail:date"")%"
End If
End If
'受信日時
If sRecvDate <> "" Then
dateUrn = ChangeDateUrnString(sRecvDate)
If dateUrn <> "" Then
If Len(strFilter) > 0 Then
strFilter = strFilter & " AND "
End If
strFilter = strFilter & "%" & dateUrn & "(""urn:schemas:httpmail:datereceived"")%"
End If
End If
'添付
If sAttach <> "" Then
attachFlag = -1
If sAttach = "有り" Then
attachFlag = 1
ElseIf sAttach = "無し" Then
attachFlag = 0
End If
If attachFlag > -1 Then
If Len(strFilter) > 0 Then
strFilter = strFilter & " AND "
End If
strFilter = strFilter & Chr(34) & "urn:schemas:httpmail:hasattachment" & Chr(34) & " = " & attachFlag
End If
End If
'1つ以上フィルタを設定していたら接頭辞を挿入する
If Len(strFilter) > 0 Then
strFilter = "@SQL=" & strFilter
End If
MakeRistrictFilter = strFilter
End Function
'--------------------------------------------------------------------
' メール保存先フォルダを作成
'--------------------------------------------------------------------
Function MakeSavePath(objFSO, sBasePath, receivedTime, oMail)
Dim sRetPath
Dim iDirNum
iDirNum = 1
sMailNumber = String(8 - Len(iDirNum), "0") & iDirNum
'ベースフォルダ\受信日_受信時_8桁通番
sRetPath = sBasePath & "\" & _
ReplaceSubjectToFileName(oMail.Subject) & "_" & _
Replace(FormatDateTime(receivedTime, vbShortDate), "/", "") & "_" & _
Replace(FormatDateTime(receivedTime, vbShortTime), ":", "") & "_" & _
sMailNumber
' 出力フォルダが存在していた場合、通番更新してフォルダ作成
If objFSO.FolderExists(sRetPath) = True Then
For iDirNum = 2 To 99999999
sMailNumber = String(8 - Len(iDirNum), "0") & iDirNum
sRetPath = sBasePath & "\" & _
ReplaceSubjectToFileName(oMail.Subject) & "_" & _
Replace(FormatDateTime(receivedTime, vbShortDate), "/", "") & "_" & _
Replace(FormatDateTime(receivedTime, vbShortTime), ":", "") & "_" & _
sMailNumber
If objFSO.FolderExists(sRetPath) = False Then
' ユニークなフォルダ名になるまで繰り返す
Exit For
End If
Next
End If
If objFSO.FolderExists(sRetPath) = False Then
On Error Resume Next
objFSO.Createfolder (sRetPath)
If Err.Number <> 0 Then
On Error GoTo 0
Err.Raise 1, "", "メール保存先フォルダの作成に失敗しました。" & vbCrLf & "[" & sRetPath & "]"
WScript.Quit()
End If
On Error GoTo 0
Else
Err.Raise 1, "", "既に保存フォルダが存在します。"
WScript.Quit()
End If
MakeSavePath = sRetPath
End Function
'--------------------------------------------------------------------
'メールと添付ファイルを保存
'--------------------------------------------------------------------
Sub SaveMailAndFile(oFS, oMail, sSavePath)
Dim oAttachments
Set oAttachments = oMail.Attachments
sMsgFileName = sSavePath & "\" & ReplaceSubjectToFileName(oMail.Subject) & ".txt"
On Error Resume Next
oMail.SaveAs sMsgFileName, olMSG
If Err.Number <> 0 Then
On Error GoTo 0
Err.Raise 1, "", "メールの保存に失敗しました。" & vbCrLf & "[" & sMsgFileName & "]"
WScript.Quit()
End If
On Error GoTo 0
For i = 1 To oAttachments.Count
If oFS.FileExists(sSavePath & "\" & oAttachments(i).FileName) = False Then
On Error Resume Next
oAttachments(i).SaveAsFile (sSavePath & "\" & oAttachments(i).FileName)
If Err.Number <> 0 Then
On Error GoTo 0
Err.Raise 1, "", "添付ファイルの保存に失敗しました。" & vbCrLf & "[" & sSavePath & "\" & oAttachments(i).FileName & "]"
' WScript.Quit()
End If
On Error GoTo 0
Else
Err.Raise 1, "", "既に同じファイル名の添付ファイルが存在します。"
' WScript.Quit()
End If
Next
End Sub
'--------------------------------------------------------------------
'メール件名でファイル名で禁止された文字を削除
'--------------------------------------------------------------------
Function ReplaceSubjectToFileName(sSubject)
Dim sRetName
Dim notAllowFileName
Dim i
sRetName = sSubject
notAllowFileName = Split("/,\,:,*,<,>,?,"",|," & vbTab, ",")
For i = 0 To UBound(notAllowFileName)
sRetName = Replace(sRetName, notAllowFileName(i), "")
Next
If Len(sRetName) > 256 Then
sRetName = Mid(sRetName, 1, 256)
End If
ReplaceSubjectToFileName = sRetName
End Function
