- 締切済み
添付ファイルの抽出
メール添付から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
- CafeBrake
- お礼率61% (8/13)
- Visual Basic
- 回答数2
- ありがとう数4
- みんなの回答 (2)
- 専門家の回答
みんなの回答
- KenKen_SP
- ベストアンサー率62% (785/1258)
こんにちは。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
- popesyu
- ベストアンサー率36% (1782/4883)
テストも何もしていませんが直感的に For folderCount = 1 To personalFolder.Folders.Count ↓ For folderCount = 1 To 1 こう修正したら受信トレイだけになりませんかね。
お礼
popesyuさん ご回答ありがとうございます。 早速、試してみたのですが 1 To 1にすると抽出ができないよです。 でも、何かそういうことですよね。いろいろ試してみます。 ありがとうございます。
関連するQ&A
- ダイレクトに目的のフォルダを指定する方法は?
全てのフォルダをループするのではなく、 ダイレクトに目的のフォルダを指定する方法はありますか? アクセスからアウトルックの該当のフォルダの中身を取得したいのですが 下記コードで目的通り取得できるのですが コードが遠回りの気がします。 ダイレクトにフォルダを指定する方法があれば教えてください。 Sub test() Dim myNaSp As Namespace Dim myFolder As MAPIFolder Dim mySecFolder As MAPIFolder Dim myThrFolder As MAPIFolder Dim FolderName As String Dim myItem As MailItem Dim myindex As Long Set cn = CurrentProject.Connection Set myNaSp = GetNamespace("MAPI") For Each myFolder In myNaSp.GetDefaultFolder(olFolderInbox).Folders For myindex = 1 To myFolder.Items.Count Set myItem = myFolder.Items(myindex) If myFolder.Name = "testフォルダ" Then Debug.Print myItem.Body End If Next Next Set myNaSp = Nothing Set myFolder = Nothing End Sub
- ベストアンサー
- オフィス系ソフト
- outlook 実際のアイテム数より1多い数が取得
http://www.geocities.co.jp/SiliconValley-Bay/3475/outlook_vba.html の フォルダ内のすべてのメールを処理 Dim ns As NameSpace Dim mf As MAPIFolder Dim x As Integer Set ns = GetNamespace("MAPI") Set mf = ns.Folders("個人用フォルダ").Folders("test") For x = 1 To mf.Items.Count ' ここに処理を記述 Next MsgBox x & "件の処理が終了しました。" を実行すると、実際のアイテム数より1多い数が取得されるのですが なぜでしょうか?
- ベストアンサー
- その他(プログラミング・開発)
- 実行時エラー配列のインデックスが範囲内にありません
アウトルックvbaで、受信トレイのメールをすべてループして、 該当のメールを削除するコードを作ったのですが 連続して削除しようとすると 実行時エラー-2147352567 「配列のインデックスが範囲内にありません」になります。 ------------------------------------------------------------------- Sub test() Dim requestsFolder As MAPIFolder Dim appNameSpace As NameSpace Dim requestMailItem As MailItem Dim i As Integer Dim j As Long '削除した個数を数える Set appNameSpace = Application.GetNamespace("MAPI") Set requestsFolder = appNameSpace.GetDefaultFolder(olFolderInbox) j = 1 For i = 1 To requestsFolder.Items.Count Set requestMailItem = requestsFolder.Items.Item(i) If requestMailItem.Subject Like "*キャンペーン*" Then '削除済みフォルダへ移動する requestMailItem.Delete Debug.Print j & "個目削除" j = j + 1 End If Next i End Sub ------------------------------------------------------------------- このコードを使っています。 エラーになるのは、 2個目削除後だったり、3個目削除後だったりさまざまで安定しません。 このエラーになる原因がわからないので教えていただけますか? アウトルックのエラーというより、 Fornextステートメントのエラーという気がします。 ご教授よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- 【続】VBSでメール件数カウント(サブフォルダ有)
「VBSでメール件数カウント」の続きなのですが、 「受信フォルダ」の下にサブフォルダがあった場合の、 件数カウントはどうすればよいでしょうか? 試しに作ってみましたのですが、自信がないので、 よろしければ診ていただけないでしょうか? ------------------------------------------------------------ Private Function Cnt_MailItem Cnt_MailItem = 0 Set oApp = CreateObject("Outlook.Application") Set oNs = oApp.GetNameSpace("MAPI") Set oFol = oNs.GetDefaultFolder(6) '受信アイテイム Cnt_MailItem = oFol.Items.Count 'サブフォルダカウント Cnt_MailItem = Cnt_MailItem + Cnt_SubFol(oFol) msgbox "メール数:" & Cnt_MailItem End Function 'サブカウント Private Function Cnt_SubFol(byVal pFol ) 'サブがない場合は数えない If pFol.Folders.Count <= 0 Then Exit Function End If For i = 1 To pFol.Folders.Count Set oItems = pFol.Folders.Item(i) Cnt_SubFol = Cnt_SubFol + oItems.Items.Count + Cnt_SubFol(oItems) next Set oItems = Nothing End Function ------------------------------------------------------------ よろしくお願い致します。
- ベストアンサー
- Visual Basic
- Outlook内のZipをフォルダに送るスクリプト
Outlookに送られてくるメール内のZipファイルをあるサーバーのフォルダに送りたいのですが、どうもEnd Subエラーが出てうまくいきません。下記のVBスクリプトを見ていただき回答をいただければ助かります。どうぞよろしくお願いいたします。 Public Sub Application_Startup() Call MailParser End Sub Private Sub Application_NewMail() Call MailParser End Sub Public Sub MailParser() Dim objContactsFolder, objContactItem, intItemCounter Dim tdystart As Date Const olFolderContacts = 6 '6 (Inbox) subject line 5 (Sent) uses mail subject line 10 (Contacts) uses full name Dim MyTempFolderString As String MyTempFolderString = "" Dim Mydate Mydate = DateFix Set objContactsFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts) Set SubFolder = objContactsFolder.Folders("Inbox") ' Example ("AAA") intItemCounter = SubFolder.Items.Count If intItemCounter = 0 Then Exit Sub 'position counter for the item Set objContactItem = SubFolder.Items(intItemCounter) 'set to last email Set mymailitem = SubFolder.Items(intItemCounter) For I = 1 To intItemCounter Step 1 DoEvents Dim TempDir As String TempDir = "" Set mymailitem = SubFolder.Items(I) 'check for source If InStr(mymailitem.Subject, "Outlook内のファイル件名が入ります") <> 0 Then MyTempFolderString = "\\フォルダ名が入ります\" ElseIf InStr(mymailitem.Subject, "上と同じOutlook内のファイル件名が入ります") <> 0 Then MyTempFolderString = "\\上と同じフォルダ名が入ります\" End If If MyTempFolderString = "" Then GoTo NextI myAttachCount = mymailitem.Attachments.Count 'set counter for number of attachments Do Until myAttachCount = 0 DoEvents Set myAttachments = mymailitem.Attachments myAttachments.Item(myAttachCount).SaveAsFile MyTempFolderString & Mydate & myAttachments.Item(myAttachCount).DisplayName Loop NextI: Next I End Function Function OpenOutlookFolder(StrFolderPath As String) As Outlook.MAPIFolder Dim arrFolders As Variant, _ varFolder As Variant, _ bolBeyondRoot As Boolean On Error Resume Next If StrFolderPath = "" Then Set OpenOutlookFolder = Nothing Else Do While Left(StrFolderPath, 1) = "\" StrFolderPath = Right(StrFolderPath, Len(StrFolderPath) - 1) Loop arrFolders = Split(StrFolderPath, "\") For Each varFolder In arrFolders Select Case bolBeyondRoot Case False Set OpenOutlookFolder = Outlook.Session.Folders(varFolder) bolBeyondRoot = True Case True Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder) End Select If Err.Number <> 0 Then Set OpenOutlookFolder = Nothing Exit For End If Next End If On Error GoTo 0 End Function Function DateFix() If Len(Month(Now)) < 2 Then strMM = "0" & Month(Now) Else strMM = Month(Now) End If If Len(Day(Now)) < 2 Then strDD = "0" & Day(Now) Else strDD = Day(Now) End If DateFix = Year(Now) & "_" & strMM & "_" & strDD End Function
- 締切済み
- その他(インターネット・Webサービス)
- ExcelVBAで添付ファイルをつけたいです。
Excelで顧客のアドレス帳を作成しており、そのアドレス帳全員に同じ文面でメールを送信したいと思い、マクロを作成しております。 調べながらここまではきたのですが、添付ファイルが着きません。 お手数ですが、どなたか自身のデスクトップ上にあるフォルダ内のPDFを 全メールに添付する方法を教えて頂けますでしょうか。 実行しようとすると「添付できるのは、ファイルかオブジェクトに限られます。」と出てしまいます。 ご教示の程、宜しくお願い致します。 下記書いたコードです。 Sub 自動送信Sample() Dim OL As Outlook.Application Dim MI As Outlook.MailItem Dim R_Start As Integer, R_End As Integer Dim Tenp1 As String, Tenp2 As String Set OL = CreateObject("Outlook.Application") Tenp1 = Worksheets("Sheet1").Range("B4") '添付1 Tenp2 = Worksheets("Sheet1").Range("B5") '添付2 R_Start = Worksheets("Sheet1").Range("G2") + 7 '開始番号(開始行) R_End = Worksheets("Sheet1").Range("I2") + 7 '終了番号(終了行) For R_Start = R_Start To R_End Set MI = OL.CreateItem(olMailItem) MI.SentOnBehalfOfName = Worksheets("Sheet1").Range("B2") '差出人 MI.Subject = Worksheets("Sheet1").Range("B3") '件名 MI.To = Worksheets("Sheet1").Cells(R_Start, "B") 'To MI.CC = Worksheets("Sheet1").Cells(R_Start, "C") 'CC MI.BCC = Worksheets("Sheet1").Cells(R_Start, "D") 'BCC '添付 If Tenp1 <> "" Then MI.Attachments.Add Tenp1 End If If Tenp2 <> "" Then MI.Attachments.Add Tenp2 End If '本文 MI.Body = Worksheets("Sheet1").Cells(R_Start, "E") & vbCr _ & Worksheets("Sheet1").Cells(R_Start, "F") & vbCr & vbCr _ & Worksheets("Sheet2").Range("A3") MI.Display 'メール表示 Next Set OL = Nothing Set MI = Nothing MsgBox "完了!" End Sub
- ベストアンサー
- Excel(エクセル)
- GetNamespaceで、コンパイルエラー
アクセスからアウトルックの受信メールを操作しようとしているのですが Private Sub test1() Dim requestsFolder As MAPIFolder Dim appNameSpace As Namespace Dim requestMailItem As MailItem Dim i As Integer '受信フォルダの取得 Set appNameSpace = Application.GetNamepace("MAPI") Set requestsFolder = appNameSpace.GetDfaultFolder(olFolderInbox) ・ ・ ・ End Sub これを実行すると GetNamespaceで、コンパイルエラーになります。 Microsoft Outlook ○.○ Object Library で、アウトルックに参照設定はしているのですが アクセスからはGetNamespaceは使えないのでしょうか?
- ベストアンサー
- オフィス系ソフト
- OutLookVBA 指定のフォルダをアクティブ化
こんばんは、よろしくお願いいたします。 OUTLOOK VBAで指定のフォルダをアクティブにするコードが分かりません。 Windows:VISTA OutLook:2007 ○.Display とすると、別ウィンドウが立ち上がってそのフォルダが表示されます。 ○.Activate とするとエラーになります。 別ウィンドウではなくアクティブフォルダが遷移する、とするにはそう すればいいでしょうか? ご指導お願いいたします。 Sub foldpl() Dim ns As NameSpace Dim mf As MAPIFolder Set ns = GetNamespace("MAPI") Set mf = ns.Folders("個人用フォルダ").Folders("送信済みアイテム") mf.Display '別ウィンドウで表示されてしまします Set mf = Nothing Set ns = Nothing End Sub
- ベストアンサー
- その他MS Office製品
- AccessからOutlookを立上げファイル添付で自動メールしたいのですが
以下のようなプログラムでファイルを添付して自動的にメール送信したいと思いました。しかし、.Attachments.Add Me![Attachment]のところで、「オブジェクトは、このプロパティーまたはメソッドは、サポートしていません。」というエラーでうまくいきません。Attachmentsで点を打つとAddが表示され、メンバーとして存在しているのになぜエラーになるのでしょうか?このエラーを回避する方法を教えて頂けないでしょうか?WinXP Professionalで、Access2003を使用しております。 Dim appOutlook As Outlook.Application Dim objMailItem As Outlook.MailItem Set appOutlook = CreateObject("Outlook.Application") Set objMailItem = appOutlook.CreateItem(olMailItem) ... With objMailItem .To = Me![宛先] .CC = Me![CC先] .Subject = Me![件名] .Attachments.Add Me![Attachment] .Body = Me![内容] .Display .Send End With appOutlook.Quit Set objMailItem = Nothing Set appOutlook = Nothing
- 締切済み
- その他MS Office製品
- OutlookVBAは他のVBAと違って入力支援は無いのですか?
Outlook2003を使っています。 たとえば、 Public Sub AllMaildisp() Dim mlitem As NameSpace Dim fd As MAPIFolder Dim cnt As Long Set mlitem = GetNamespace("MAPI") ' 対象メールボックス Set fd = mlitem.Folders("電子メール").Folders("受信トレイ") For cnt = 1 To 3 'For cnt = 1 To fd.Items.Count Debug.Print fd.Items(cnt).Subject Debug.Print fd.Items(cnt).Body Debug.Print fd.Items(cnt).ReceivedByName Debug.Print fd.Items(cnt).ReceivedTime Debug.Print fd.Items(cnt).To Debug.Print fd.Items(cnt).CC Debug.Print fd.Items(cnt).BCC Next cnt End Sub のときにfd.Items(cnt). と入力したら、ExcelのVBAとかだとその次のプロパティの候補が表示されると思いますが表示されません。 この場合 既に書いてありますが、CC とか BCC とか Toとかだと思います。 表示する方法はありますか?
- 締切済み
- その他(プログラミング・開発)
お礼
KenKen_SP さん ご回答ありがとうございます。 受信トレイのみ抽出できました^^ 参考につけていただいたFor Each ステートメントの 方も頑張って使ってみます。勉強になります。 有難うございましたm(_ _)m