添付ファイルの抽出

質問

メール添付からpdfを抽出するために下記のVBAを使用しています。
今までは受信トレイのサブフォルダも含めていたのですが
今後は受信トレイのみにしたいのですがどこをどのように変更したらいいのか解りません。
解る方いましたら教えてください。お願いします。

Sub 抽出()

Dim personalFolder As MAPIFolder
Dim requestsFolder As MAPIFolder
Dim object As Object
Dim appNameSpace As NameSpace
Dim requestMailItem As MailItem
Dim mailCount As Integer
Dim folderCount As Integer
Dim tempCount As Integer

'ルートフォルダ取得
Set appNameSpace = Application.GetNamespace("MAPI")
Set personalFolder = appNameSpace.Folders.Item(1)

'ルートフォルダ配下のループ
For folderCount = 1 To personalFolder.Folders.Count

'フォルダ一覧からfolderCount件目のフォルダ取得
Set requestsFolder = personalFolder.Folders.Item(folderCount)

'フォルダに存在するメールの件数分ループ
For mailCount = 1 To requestsFolder.Items.Count

'フォルダのmailCount件目のメールのタイプをチェック
If TypeOf requestsFolder.Items.Item(mailCount) Is MailItem Then

'フォルダからmailCount件目のメール取得
Set requestMailItem = requestsFolder.Items.Item(mailCount)

'添付ファイルの件数分ループ
For tempCount = 1 To requestMailItem.Attachments.Count

'添付ファイルの拡張子をチェック
If Right(requestMailItem.Attachments.Item(tempCount).FileName, 3) = "pdf" Then

'添付ファイルを保存
requestMailItem.Attachments.Item(tempCount).SaveAsFile _
"C:\My Documents" + "\" + requestMailItem.Attachments.Item(tempCount).DisplayName

End If

Next

End If

Next

Next

End Sub

回答No.2

KenKen_SP

こんにちは。KenKen_SP です。

> 'ルートフォルダ配下のループ
> For folderCount = 1 To personalFolder.Folders.Count
> 'フォルダ一覧からfolderCount件目のフォルダ取得
> Set requestsFolder = personalFolder.Folders.Item(folderCount)

この後にフォルダ名判定を挟めば良いです。

　　If requestsFolder.Name = "受信トレイ" Then
　　　　～（略）
　　End If

同じ処理内容なので蛇足ですけど、For Each ステートメントを使った方が、
コードに無駄がなく、スッキリしますね。ご参考までに。

' // 添付ファイルを指定フォルダに保存する
Sub Sample()

　　Dim oNameSpace　　As NameSpace
　　Dim oRootFolder　 As MAPIFolder
　　Dim oFolder　　　 As MAPIFolder
　　Dim oItem　　　　 As Object
　　Dim oFile　　　　 As Attachment
　　Dim sExtension　　As String

　　' この定数の内容を適当に修正して下さい
　　Const MAPI_DIRNAME As String = "受信トレイ"
　　Const FILE_FILTER As String = "*.pdf"
　　Const FILE_SAVEDIR As String = "C:\My Documents"

　　Set oNameSpace = Application.GetNamespace("MAPI")
　　Set oRootFolder = oNameSpace.Folders.Item(1)
　　Set oFolder = GetMAPIFolderByName(MAPI_DIRNAME, oRootFolder)
　　On Error GoTo ERROR_HANDLER
　　If oFolder Is Nothing Then
　　　　Err.Raise 1000, , "フォルダ[ " & MAPI_DIRNAME & " ]は無い？"
　　End If

　　For Each oItem In oFolder.Items
　　　　If TypeOf oItem Is MailItem Then
　　　　　　For Each oFile In oItem.Attachments
　　　　　　　　If UCase$(oFile.FileName) Like UCase$(FILE_FILTER) Then
　　　　　　　　　　oFile.SaveAsFile FILE_SAVEDIR & "\" & oFile.FileName
　　　　　　　　End If
　　　　　　Next
　　　　End If
　　Next
　　MsgBox "終わりました(´・ω・`)", vbInformation

TERMINATE:
　　On Error GoTo 0
　　Exit Sub
ERROR_HANDLER:
　　MsgBox Err.Description, vbCritical
　　Resume TERMINATE
End Sub

' // MAPIFolder オブジェクトをフォルダ名で取得する
Private Function GetMAPIFolderByName( _
　　ByVal FolderName As String, _
　　ByRef ParentFolder As MAPIFolder _
) As MAPIFolder

　　' @引　数： FolderName　 探すフォルダ名
　　'　　　　： ParentFolder 検索ルートフォルダ MAPIFolder Object
　　' @戻り値： 見つかったとき MAPIFolder Object/ 見つからない Nothing
　　' @備　考： 再帰呼び出しでサブフォルダも検索してます

　　Dim oFolder As MAPIFolder

　　For Each oFolder In ParentFolder.Folders
　　　　If oFolder.Name = FolderName Then
　　　　　　Set GetMAPIFolderByName = oFolder
　　　　　　Exit For
　　　　ElseIf oFolder.Folders.Count > 0 Then
　　　　　　Set GetMAPIFolderByName = GetMAPIFolderByName(FolderName, oFolder)
　　　　End If
　　Next

End Function

お礼

KenKen_SP さん

ご回答ありがとうございます。
受信トレイのみ抽出できました＾＾

参考につけていただいたFor Each ステートメントの
方も頑張って使ってみます。勉強になります。
有難うございましたm(_ _)m

回答No.1

popesyu

テストも何もしていませんが直感的に
For folderCount = 1 To personalFolder.Folders.Count
↓
For folderCount = 1 To 1
こう修正したら受信トレイだけになりませんかね。

お礼

popesyuさん
ご回答ありがとうございます。
早速、試してみたのですが
1 To 1にすると抽出ができないよです。
でも、何かそういうことですよね。いろいろ試してみます。
ありがとうございます。