Excel＋Outlookで受信メールのリスト作成。添付ファイル名が取得できない

受信しているメールの情報をリスト化して統計化しようとしています。
環境はWin7 32bit + Office2010、Excel2010/Outlook2010利用になります。

件名、送信日、送信者、宛先、CC、本文、添付ファイル名を取得し
シートに貼ってリスト化したいです。
添付ファイル名以外はうまくいっています。

添付ファイル名をどう取得すればよいか、
お力をお貸しください。。。

色々調べましたが、「ファイルの保存」はサンプルがあるものの
ファイル名の保存が見つかりません。

ExcelVBA
1Sub メール抽出()
2
3Dim oApp As Object
4Dim myNameSpace As Object
5Dim myFolder As Object
6Dim Fname As String
7
8
9Application.ScreenUpdating = False '画面更新停止
10Application.Calculation = xlCalculationManual '自動計算を手動に変更
11ThisWorkbook.Worksheets("MAIL").Cells.Clear
12Fname = Worksheets("説明操作").Range("B17")
13
14    
15    Set oApp = CreateObject("Outlook.Application") 'outlook 起動
16    Set myNameSpace = oApp.GetNamespace("MAPI")
17    Set myFolder = myNameSpace.GetDefaultFolder(6).Folders(Fname) 'メール作業フォルダ指定
18    'myFolder.Display
19    
20    Dim objMAILITEM As Object 'メールアイテム
21    Dim n As Integer  'カウンター
22    Dim strlen As Long
23    Dim objAttach As Attachment
24    Dim strAtt As String
25
26    
27    strlen = Worksheets("説明操作").Range("B18")
28    
29    For n = 1 To myFolder.Items.Count  'フォルダのアイテム数分ループ
30        'メールを１通取り出す、変数にセット
31        ThisWorkbook.Worksheets("MAIL").Cells(n, "A") = objMAILITEM.Subject         '件名
32        ' ThisWorkbook.Worksheets("MAIL").Cells(n, "B") = objMAILITEM.Attatch.Filename '添付ファイル名,取れない
33        ThisWorkbook.Worksheets("MAIL").Cells(n, "C") = objMAILITEM.receivedTime    '作成日
34        ThisWorkbook.Worksheets("MAIL").Cells(n, "D") = objMAILITEM.SenderName      '送信者
35        ThisWorkbook.Worksheets("MAIL").Cells(n, "E") = objMAILITEM.SenderEmailAddress      '送信者add
36        ThisWorkbook.Worksheets("MAIL").Cells(n, "F") = objMAILITEM.TO            '宛先
37        ThisWorkbook.Worksheets("MAIL").Cells(n, "G") = objMAILITEM.CC            'CC
38        ThisWorkbook.Worksheets("MAIL").Cells(n, "H") = Left(objMAILITEM.Body, strlen)           '本文
39    Next n
40
41'念の為受信日時で並べ替え
42ThisWorkbook.Worksheets("MAIL").Select
43Range("A:H").Sort _
44        Key1:=Range("A1"), _
45        Order1:=2, _
46        Header:=xlNo
47
48Worksheets("使い方").Select
49Application.ScreenUpdating = True '画面更新
50'Application.Calculation = xlCalculationAutomatic '手動計算を自動に変更
51MsgBox "メール抽出完了です", vbInformation, "メール抽出"
52
53End Sub

行動規範の内容に同意します

回答1件

自己解決

解決しました。

ExcelVBA
1Sub メール抽出()
2
3Dim oApp As Object
4Dim myNameSpace As Object
5Dim myFolder As Object
6Dim Fname As String
7
8
9Application.ScreenUpdating = False '画面更新停止
10Application.Calculation = xlCalculationManual '自動計算を手動に変更
11ThisWorkbook.Worksheets("MAIL").Cells.Clear
12Fname = Worksheets("説明操作").Range("B17")
13
14    
15    Set oApp = CreateObject("Outlook.Application") 'outlook 起動
16    Set myNameSpace = oApp.GetNamespace("MAPI")
17    Set myFolder = myNameSpace.GetDefaultFolder(6).Folders(Fname) 'メール作業フォルダ指定
18    'myFolder.Display
19    
20    Dim objMAILITEM As Object 'メールアイテム
21    Dim i, j As Integer 'カウンター
22    Dim strlen As Long
23    Dim Afile As String '添付ファイル名
24    
25    strlen = Worksheets("説明操作").Range("B18")
26    
27    For i = 1 To myFolder.Items.Count  'フォルダのアイテム数分ループ
28        'メールを１通取り出す、変数にセット
29        Set objMAILITEM = myFolder.Items(i)
30        
31        ThisWorkbook.Worksheets("MAIL").Cells(i, "A") = objMAILITEM.Subject         '件名
32        
33        For j = 1 To myFolder.Items(i).Attachments.Count
34            Afile = myFolder.Items(i).Attachments.Item(j).Filename '添付ファイル名抽出
35            ThisWorkbook.Worksheets("MAIL").Cells(i, "B") = i & "-" & Afile
36        Next j
37        
38        ThisWorkbook.Worksheets("MAIL").Cells(i, "C") = objMAILITEM.receivedTime    '作成日
39        ThisWorkbook.Worksheets("MAIL").Cells(i, "D") = objMAILITEM.SenderName      '送信者
40        ThisWorkbook.Worksheets("MAIL").Cells(i, "E") = objMAILITEM.SenderEmailAddress      '送信者add
41        ThisWorkbook.Worksheets("MAIL").Cells(i, "F") = objMAILITEM.To            '宛先
42        ThisWorkbook.Worksheets("MAIL").Cells(i, "G") = objMAILITEM.CC            'CC
43        ThisWorkbook.Worksheets("MAIL").Cells(i, "H") = Left(objMAILITEM.Body, strlen)           '本文
44    Next i
45
46'念の為受信日時で並べ替え
47ThisWorkbook.Worksheets("MAIL").Select
48Range("A:H").Sort _
49        Key1:=Range("A1"), _
50        Order1:=2, _
51        Header:=xlNo
52
53Worksheets("使い方").Select
54Application.ScreenUpdating = True '画面更新
55'Application.Calculation = xlCalculationAutomatic '手動計算を自動に変更
56MsgBox "メール抽出完了です", vbInformation, "メール抽出"
57
58End Sub
59
60