Outlookで選択したメールの書き出しについて
- Outlookで選択したメールのみ書き出すVBAを教えてください。
- 現在のコードではフォルダ内すべてのメールが書き出されてしまいます。
- 選択しているメールのみ書き出すコードに変更する方法を教えてください。
- ベストアンサー
Outlookで選択したメールのみ書き出すVBA
こんにちは。 Outlookで選択したメールのみ書き出すVBAを教えてください。 下記のコードまでは作成ができ、書き出すことには成功しました。 ですが、下記コードだとフォルダ内すべてのメールが書き出しされてしまいます。 選択しているメールのみ書き出すコードに書き換えたいのですが、 どこを変えたらよいかわかりません。 どなたかご教示いただけると幸いです。 ------------------------------------------- Sub メール書き出し() On Error Resume Next Set myMFolder = Application.ActiveExplorer.CurrentFolder Set xlApp = CreateObject("Excel.Application") Set myBook = xlApp.Workbooks.Add xlApp.Visible = True With myBook.Worksheets(1) i = 1 For Each myItem In myMFolder.Items '受信日時 .Cells(i, 1) = myItem.ReceivedTime '受信者名 .Cells(i, 2) = myItem.Recipients(1).Name '件名 .Cells(i, 3) = myItem.Subject '送信者名 .Cells(i, 4) = myItem.SenderName '受信者名 .Cells(i, 5) = myItem.Recipients(1).Addresss i = i + 1 Next myItem End With Set xlApp = Nothing End Sub
- airas96
- お礼率40% (2/5)
- オフィス系ソフト
- 回答数1
- ありがとう数2
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
こんばんは。 こんな感じで。 On Error Resume Next Set mySelection = Application.ActiveExplorer.Selection '変更 Set xlApp = CreateObject("Excel.Application") Set myBook = xlApp.Workbooks.Add xlApp.Visible = True With myBook.Worksheets(1) i = 1 For Each myItem In mySelection '変更 ・・・・
関連するQ&A
- Outlook2010のメール書き出しVBAについ
Outlook2010のメール書き出しVBAを作成しました。 １行目に見出しをいれたいのですがうまく入れられません。 また、800件程度のメールを書きだそうとすると、書き出したエクセルの途中の行に７行くらい空の行が入ってしまいます。 どこをどう直せばよいかよくわからず、 どなたか修正いただけると幸いです。 ---------------------------- Sub メール書き出し日にちのみ() On Error Resume Next Set mySelection = Application.ActiveExplorer.Selection '変更 Set xlApp = CreateObject("Excel.Application") Set myBook = xlApp.Workbooks.Add xlApp.Visible = True With myBook.Worksheets(1) i = 1 For Each MyItem In mySelection '変更 '受信日時 .Cells(i, 1) = MyItem.ReceivedTime '送信者名 .Cells(i, 2) = MyItem.SenderName i = i + 1 Next MyItem End With Set xlApp = Nothing End Sub
- ベストアンサー
- Visual Basic
- outlook 選択したメールの書き出し
こんばんわ。 Outlook2010で選択したメールの書き出しをするマクロを作成しました。 選択したメール数が少ない場合は問題なく動作するのですが、 メール数が多くなる（200件以上）の場合途中にスペースが入ってしまい、 １列目と２列目がずれることがあります。 どの部分を修正すればうまく動くでしょうか。（ずれているイメージは画像を添付しました） また、以下のマクロで書き出したデータの１行目にタイトルを入れたいです。 excelのA1には【日時】 excelのB1には【送信者】 を入れたいと思っています。 どのように入れたらよいか分からず、困っています。 教えていただけると幸いです。 ------------------------------------------ Sub メール書き出し日にちのみ() On Error Resume Next Set mySelection = Application.ActiveExplorer.Selection '変更 Set xlApp = CreateObject("Excel.Application") Set myBook = xlApp.Workbooks.Add xlApp.Visible = True With myBook.Worksheets(1) i = 1 For Each myItem In mySelection '変更 '受信日時 .Cells(i, 1) = myItem.ReceivedTime '送信者名 .Cells(i, 2) = myItem.SenderName i = i + 1 Next myItem End With Set xlApp = Nothing End Sub
- 締切済み
- オフィス系ソフト
- EXCELの配列で
メールの本文を1行づつよみとってEXCELへ書き出そうと思っています。 Sub getMail1() Dim myOl As New Outlook.Application Dim dFolder As MAPIFolder Dim myItem As MailItem Dim delItem As MailItem Dim myRecipient As Recipient Dim i As Long, j As Long Const mAddress = 0, mTel = 1, mName = 2, mAge = 3 Set dFolder = myOl.GetNamespace _ ("MAPI").Folders("個人用フォルダ").Folders("単発") i = 1 On Error Resume Next For Each myItem In dFolder.Items i = i + 1 Set delItem = myItem.Reply For Each myRecipient In delItem.Recipients If InStr(1, myRecipient.Address, "@", vbBinaryCompare) _ <> 0 Then Exit For End If Next delItem.Delete With ActiveSheet myBody = Split(myItem.Body, vbCrLf) .Cells(i, 1).Value = myRecipient.Address .Cells(i, 2) = myItem.SenderName .Cells(i, 3) = myItem.Subject .Cells(i, 4) = myItem.ReceivedTime For j = 0 To UBound(myBody) i = i + 1 On Error Resume Next .Cells(i, 1) = myBody(j) .Cells(i, 1).MergeCells = True Next End With i = i + 1 Next Set myOl = Nothing End Sub このようなコードを書いて書き出すことは出来たのですが配列が縦になってしまいます。 横に配列したいのですが教えてください。 伊藤太郎 東京都 03-3123-4567を 伊藤太郎 東京都 03-3123-4567 としたいです。 よろしくお願いします。
- ベストアンサー
- Visual Basic
- VBA
次のように偏差値を求めるプログラムを書くと、アプリケーションの定義エラーと表示されます。誰か理由をお教えください。 Sub hensati() With Worksheets("C") For i = 2 To 43 x = Cells(G, 1) y = Cells(G, 2) Cells(i, 3) = (Cells(i, 2) - x) / y * 10 + 50 Next i End With End Sub
- ベストアンサー
- Visual Basic
- VBA教えて下さい
VBAのコード考えましたが上手くできません まず、例として ファイル名を 試験1 試験2の2つのエクセルのファイルがあります やりたい事 セルを1つ1つ調べる 試験1のファイル(今開いてるシート) のD1～D20セルのどれかのセルが何か入力されているならば 試験2のファイル(今開いてるシート) のB1～B20セルのどれかのセルをクリアする(例えばD5セルに値が入ってればB5セルをクリアすると言う内容です) をしたいです 考えたコードを書きます sub test() dim a as variant dim i as variant set a = workbooks("試験2").activesheet with workbooks("試験1").activesheet for i = 1 to 20 if cells(i,"D") <> "" then cells(i,a).clear end if next i end with end sub これでは上手く結果がでませんでした 勉強不足ですみませんm(__)m 宜しければコードを書いてくれると助かります 回答お願いします
- ベストアンサー
- Visual Basic
- 一通ずつ処理したい（アウトルックVBA）
下記のようなＶＢＡソースを走らせております。 アウトルックでメールを受信し、受信トレイ入ったメールの本文内にある"昭和"または"平成"のキーワードを読み分けて、某プログラムを走らせるものです。某プログラムはShellで呼び出してから動き始め20秒程度で終了します。ほとんどの場合、一回の受信で、1通しかメールが入りませんが、まれに2通入る事が有ります(同時接続のクライアントは2台なので、同時に送られると2通入りますが、3通以上同時に入る事はありえません） その場合、下記のソースで走らせると、一度に二つのshellが立ち上がってしまい、不具合が生じます（同種同時あるいは異種同時起動ができないプログラム仕様なので） そこで、一つ目の処理が終わってから、二つ目の処理に入る・・・という動きにしたいのですが、見当がつきません。 ご教示をいただけると助かります。宜しくお願いします。 Private Sub Application_NewMail() Const SEARCHWORDA = "昭和" Const SEARCHWORDB = "平成" Dim myNS As NameSpace Dim myInBox As MAPIFolder Dim myItem As MailItem Set myNS = Outlook.Application.GetNamespace("MAPI") Set myInBox = myNS.GetDefaultFolder(olFolderInbox) For Each myItem In myInBox.Items If InStr(myItem.Body, SEARCHWORDA) > 0 Then shell "hoge1.exe" End If If InStr(myItem.Body, SEARCHWORDB) > 0 Then shell "hoge2.exe" End If Next End Sub
- 締切済み
- Visual Basic
- Excel VBA msoAutomationSecurityForceDisableについて
マクロを無効にしてファイルを読み込むコードを過去レスを見て作成しましたが、msoAutomationSecurityForceDisableを定数でなく、変数としか認識しないため、うまく機能しません。 下記コードのどこを修正すべきか、ご教示願います。 Sub read() Dim DirN As String Dim Fname As String With ThisWorkbook.Worksheets("手当") .Activate .Range(.Cells(7, 1), .Cells(10000, 40)).ClearContents End With Set NxL = CreateObject("Excel.application") NxL.Visible = True NxL.AutomationSecurity = msoAutomationSecurityForceDisable NxL.DisplayAlerts = False DirN = Worksheets("手当").Range("C2").Value & "\" Fname = Dir(DirN & "*.xls") Set Mybook = NxL.Workbooks.Open(DirN & Fname) Call read1(Mybook) Do While Fname <> "" Set NxL = CreateObject("Excel.application") NxL.Visible = True NxL.AutomationSecurity = msoAutomationSecurityForceDisable NxL.DisplayAlerts = False '追加してファイル名を検索する場合はDir関数の引数はなくす。 Fname = Dir() Set Mybook = NxL.Workbooks.Open(DirN & Fname) Call read1(Mybook) Loop End Sub
- ベストアンサー
- オフィス系ソフト
- VBA教えて下さい
for nextの使い方がわかりません 変数を使用し条件に当てはまる数値だけ 処理するといった内容です 考えたコード sub test() dim a as variant dim b as variant dim i as variant with workbooks("book1").activesheet set a =.range("A5") set b =.range("B5") end with with workbooks("book2").activesheet for i = 80 to 110 if a = cells(i,1) then b.value = cells(i,2) end if next i end sub このコードにてやりたい事は まず、book1の今開いてるシートを参照し A5セル、B5セルをセットし (例えばA5は2と入力している B5セルは10000と入力している) 次に、book2の今開いてるシートを参照し もし、1行目の80～110どれかのセルの数字が 変数aと同じ値ならば (A行80～110行のセルの数字2があれば 例えば85列) 変数bの数字を2行目の80～110に条件に当てはまるセルに移す (B行85列にB5セルの値10000を移す) ()の部分は例えで書いてます 読みにくかったら無視でお願いしますm(__)m 指定の仕方など間違ってると思うので コードを書いてくれると助かります 回答お願いしますm(__)m
- ベストアンサー
- Visual Basic
- VBAに関する質問です
現在、以下の記述で項目の名称が一致した場合、数字の加算集計を行って名称と加算結果を別シートに表示させるマクロを使用しています。 このマクロに記述を加えて、『部署名別に項目名が一致した場合、数字の加算を行って部署名、項目名、加算集計結果を別シートに並べて表示させる』というマクロを作る場合、どのように記述すれば宜しいでしょうか？ ご回答宜しくお願いします。 Sub sample() Dim i As Long, db, wk Set db = CreateObject("Scripting.Dictionary") For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row wk = Cells(i, "A") db(wk) = db(wk) + Cells(i, "B") Next With Sheets("sheet2") wk = db.keys For i = 0 To UBound(wk) .Cells(i + 1, "A") = wk(i) .Cells(i + 1, "B") = db(wk(i)) Next End With Set db = Nothing End Sub
- 締切済み
- Visual Basic
- VBA DO～While LOOPを解除したい
いつもお世話になります。 すみません、下記のコードで 、DO～While LOOP ステートメントを解除して、一回だけ 実施するようなコードに修正したいのですが、自分ではうまく修正できません。 どうか修正したコードを教えていただけないでしょうか。 Sub ShowBarCode() Dim xlAPP As Application Dim GYO As Long Dim objOLEObject As OLEObject Dim objBarCode As BARCODELib.BarCodeCtrl Dim lngLeft As Long Dim lngTop As Long Dim intHeight As Integer Dim intWidth As Integer Dim sh As Worksheet Set xlAPP = Application xlAPP.ScreenUpdating = False xlAPP.Calculation = xlCalculationManual xlAPP.Interactive = False On Error GoTo ERROR_EXIT GYO = 66 Do While Cells(GYO, 99).Value <> "" Cells(GYO, 100).Select ' 現在セルの位置を取得 With ActiveCell lngLeft = .Left + .Width * 0.05 lngTop = .Top + 1 intHeight = .height * 0.7 intWidth = .Width * 6.9 End With ' 現在セルにバーコードを貼付ける ActiveSheet.OLEObjects.Add(ClassType:="BARCODE.BarCodeCtrl.1", _ Link:=False, DisplayAsIcon:=False, _ Left:=lngLeft, Top:=lngTop, Width:=intWidth, _ height:=intHeight).Select Set objOLEObject = Selection Set objBarCode = objOLEObject.Object With objOLEObject .Visible = False ' 一旦消去 .Placement = 2 .Visible = True ' 表示 End With With objBarCode .Style = 2 ' JAN-13 .SubStyle = 0 .Validation = 1 ' C/D修正有り .ShowData = 0 ' 数値表示なし .Value = Cells(GYO, 100).Value .Refresh End With Cells(GYO, 100).FormulaR1C1 = "=LEFT(RC1,7)&"" ""&RIGHT(RC1,6)" GYO = GYO + 1 Loop Cells(1, 1).Select xlAPP.Interactive = True xlAPP.Calculation = xlCalculationAutomatic xlAPP.ScreenUpdating = True Exit Sub ERROR_EXIT: xlAPP.Interactive = True xlAPP.Calculation = xlCalculationAutomatic xlAPP.ScreenUpdating = True MsgBox Err.Description End Sub
- ベストアンサー
- オフィス系ソフト
お礼
m3_makiさん ありがとうございます！できました！！ これでかなりの時間を短縮できます。 早急なご対応ありがとうございました。