解決したいこと
テキストファイルにある\nで改行されているものを\rによる改行に変えたいです。
(やりたいこと)
Outlook上で指定フォルダの昨日のメール情報を全て取得し、テキストドキュメントに保存
↓
テキストドキュメントをExcelの指定位置に貼り付け。
発生している問題・エラー
VBAで取得してきたテキストドキュメントのメール本文部分の改行が、画像のように¥n方式になっております。
結果、Excelに転記した際に1つのセルにまとめて格納されてしまいます。
理想としては、自動で各行が¥rで改行されいる状態でExcelに転記したいです。
・Outlookから取得した時点で¥rで改行されている
もしくは
・Outlookから¥nで取得してくるが、その後に作成したテキストドキュメントを操作して¥nの改行をすべて¥rに変える
といった方法があれば知りたいです。
お忙しいところ恐縮ですが、よろしくお願いいたします。
該当するソースコード
VBA
1Sub テキストファイル貼り付け() 2Application.ScreenUpdating = False '画面表示更新の一時停止 3Application.Calculation = xlCalculationManual '関数の計算の一時停止 4 5Dim dtStart As Date 6 Dim dtEnd As Date 7 Const TEXT_FILE = "C:\Users\us\Desktopテスト.txt" ' 保存するファイル名を指定 8 Dim strStart As String 9 Dim strEnd As String 10 Dim objOL As Object 11 Dim objNAMESPC As Object 12 Dim strFilter As String 13 Dim myfolders As Object 14 Dim objMail As MailItem 15 Dim colItems As Items 16 Dim objAttach As Attachment 17 Dim strAttach As String 18 Dim cnt As Long 19 20 dtStart = Date - 1 21 dtEnd = Date - 1 22 strStart = FormatDateTime(dtStart, vbShortDate) & " 00:00" 23 strEnd = FormatDateTime(dtEnd, vbShortDate) & " 23:59" 24 strFilter = "[受信日時] >= '" & strStart & _ 25 "' AND [受信日時] <= '" & strEnd & "'" 26 27 '保存したいメールフォルダを取得 28 Set objOL = CreateObject("Outlook.Application") 29 Set objNAMESPC = objOL.GetNamespace("MAPI") 30 Set myfolders = objNAMESPC.Folders("a@gmail.jp").Folders("テスト") 31 32 'メールフォルダをフィルタリング 33 Set colItems = myfolders.Items.Restrict(strFilter) 34 35 36 Open TEXT_FILE For Output As #1 37 For Each objMail In colItems 38 With objMail 39 Print #1, "差出人:" & .SenderName & vbTab 40 Print #1, "送信日時:" & vbTab & .SentOn 41 If .To <> "" Then 42 Print #1, "宛先:" & vbTab & .To 43 End If 44 If .CC <> "" Then 45 Print #1, "CC:" & vbTab & .CC 46 End If 47 Print #1, "件名:" & vbTab & .Subject 48 If .Attachments.Count > 0 Then 49 strAttach = "" 50 For Each objAttach In .Attachments 51 strAttach = strAttach & objAttach.Filename & "; " 52 Next 53 strAttach = Left(strAttach, Len(strAttach) - 2) 54 Print #1, "添付ファイル: " & vbTab & strAttach 55 End If 56 If .Importance <> olImportanceNormal And .Sensitivity <> olNormal Then 57 Print #1, "" 58 End If 59 If .Importance = olImportanceHigh Then 60 Print #1, "重要度:" & vbTab & "高" 61 End If 62 If .Importance = olImportanceHigh Then 63 Print #1, "重要度:" & vbTab & "低" 64 End If 65 If .Sensitivity = olConfidential Then 66 Print #1, "秘密度:" & vbTab & "社外秘" 67 End If 68 If .Sensitivity = olPersonal Then 69 Print #1, "秘密度:" & vbTab & "個人用" 70 End If 71 If .Sensitivity = olPrivate Then 72 Print #1, "秘密度:" & vbTab & "親展" 73 End If 74 If .Categories <> "" Then 75 Print #1, "" 76 Print #1, "分類項目:" & vbTab & .Categories 77 End If 78 Print #1, "" 79 Print #1, .Body 80 Print #1, "" 81 End With 82 Next 83 84 Close #1 85End Sub 86 87Sub テキストファイルの書き込み() 88 89Open "C:\Users\us\テスト.txt" For Input As #1 90 91Dim r As Long 92 r = 2 '2行目から書き出す 93 94 Do Until EOF(1) 95 Dim buf As String 96 Line Input #1, buf 97 98 Dim aryLine As Variant '文字列格納用配列変数 99 aryLine = Split(buf, vbTab) '読み込んだ行をタブ区切りで配列変数に格納 100 101 Dim i As Long 102 For i = LBound(aryLine) To UBound(aryLine) 103 'インデックスが0から始まるので列番号に合わせるため+23 104 Cells(r, i + 23).Value = "'" & aryLine(i) 105 Next 106 107 r = r + 1 108 109 Loop 110 111Close #1 112 113Application.ScreenUpdating = True '画面表示更新の再開 114Application.Calculation = xlCalculationAutomatic '関数の計算の再開 115End Sub 116
回答2件
あなたの回答
tips
プレビュー