OUTLOOK VBA 選択したメールのフォルダのメールのリストを作る Make MailItem List of selected Mail Folder

##参照設定
EXCEL
ADODB
Microsoft ActiveX Data Objects x.x Library"

##特徴
メールフォルダ（受信フォルダ、送信済みフォルダ、そのサブフォルダ）を選択してこのマクロを起動してください。
Fドライブのルートにテンポラリのテキストファイル(ユニコード)を作成し、
これをEXCELに変換します。
コンマ形式CSVからの変換であるため、アドレスやタイトル、本文のコンマを削っています。
本文はHTMLメールだとあまり内容はわかりません。
ドライブの設定は適宜変更してください
メールアドレスや本文は長いので、字数制限をかけています。

##長所
字数を制限しているせいか出来上がりは比較的早い感じがします。

##短所
字数を制限しているせいで、簡便なものになっています。

MakeSMailItemList.BAS

Sub MakeMailItemList()
'QIIQ From QIITA
'For Outlook
'Need Reffernce setteng Excel,ADODB
'Befer run this Macro, You Need Select Outllok Mail Folder(Recieve and Send , and their subfolders)
Donst Dletter as String = "F:\"
Dim myNamespace As Outlook.NameSpace
Dim myContacts As Outlook.Items
Dim myItems As Outlook.Items
Dim myItem As Outlook.MailItem
Dim myitems2 As Outlook.Items
Dim ADOS As New ADODB.Stream
Dim strfile As String
Dim olFolder As Outlook.Folder
Dim Aex As Outlook.Explorer
Dim Ain As Outlook.Inspector

Dim NavP As Outlook.NavigationPane
Dim NavM As Outlook.NavigationModule
Dim NavG As Outlook.NavigationGroup
Dim str As String
Dim olCViews As Outlook.Views, olCView As Outlook.View, olCField As Outlook.ViewField
Dim cnt As Long
Dim Wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set myNamespace = Application.GetNamespace("MAPI")
Set myContacts = myNamespace.GetDefaultFolder(olFolderInbox).Items
Set Aex = Application.ActiveExplorer
Set Ain = Application.ActiveInspector
Set NavP = Aex.NavigationPane
Set NavM = NavP.CurrentModule
Set olFolder = Aex.CurrentFolder
Set myItems = olFolder.Items
strfile = Dletter & Format(CDate(Now), "YYYYMMDDHHmmSS") & "temp.txt"
ADOS.Type = adTypeText
ADOS.Mode = 3
ADOS.Charset = "unicode"
ADOS.LineSeparator = adCR
ADOS.Mode = adModeReadWrite
ADOS.Open
If myItems.Count = 0 Then GoTo err_handle
For Each myItem In myItems
ADOS.Position = ADOS.Size
On Error Resume Next
str = ""
str = Chr(34) & Left(replacetext(CStr(myItem.SenderEmailAddress)), 50) & Chr(34) & "," & Chr(34) & Left(replacetext(CStr(myItem.To)), 10) & Chr(34) & "," & Chr(34) & Left(replacetext(CStr(myItem.CC)), 50) & Chr(34) & "," & Chr(34) & Left(replacetext(myItem.BCC), 50) & Chr(34) & "," & Format(myItem.SentOn, "YYYY/MM/DD HH:mm:ss") & "," & Format(myItem.ReceivedTime, "YYYY/MM/DD HH:mm:ss") & "," & replacetext(CStr(myItem.Subject)) & "," & Chr(34) & Left(replacetext(CStr(myItem.Body)), 50) & Chr(34) & "," & CStr(myItem.Importance) & "," & myItem.Attachments.Count ' & vbCrLf
ADOS.WriteText str, adWriteLine
ADOS.SaveToFile strfile, adSaveCreateOverWrite
Next
ADOS.Close
Excel.Application.Workbooks.OpenText FileName:=strfile, origin:=65001, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=True, _
Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array( _
3, 1), Array(4, 1), Array(5, 5), Array(6, 5), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1)), _
TrailingMinusNumbers:=True
Set Wb = ActiveWorkbook
Wb.Activate: Set ws = Wb.ActiveSheet
ws.Activate
ws.Range("A1").Value = "from"
Range("B1").Value = "to"
Range("C1").Value = "cc"
Range("D1").Value = "bcc"
Range("E1").Value = "senton"
Range("F1").Value = "receivedtime"
Range("G1").Value = "sub"
Range("H1").Value = "body"
Range("I1").Value = "importance"
Range("J1").Value = "attachments"
Range("H1").Value = "size"

Range("F1").Select
Columns("F:F").EntireColumn.AutoFit: DoEvents
Range("E1").Select
Columns("E:E").EntireColumn.AutoFit: DoEvents
strfile = Mid(strfile, 1, Len(strfile) - 4) & ".xlsx"
Wb.SaveAs FileName:=strfile, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
DoEvents
Wb.Close False
DoEvents
GoTo err_handle
Exit Sub
err_handle:
Set ADOS = Nothing
Set myNamespace = Nothing
End Sub

Function replacetext(str As String) As String
'Delete character from string
str = Replace(str, Chr(10), "", 1, -1, vbTextCompare)
str = Replace(str, Chr(13), "", 1, -1, vbTextCompare)
str = Replace(str, vbTab, "", 1, -1, vbTextCompare)
str = Replace(str, " ", "", 1, -1, vbTextCompare) 'Hankaku Space
str = Replace(str, "　", "", 1, -1, vbTextCompare) 'Zenkaku Space
str = Replace(str, ",", "", 1, -1, vbTextCompare)
str = Replace(str, "---", "", 1, -1, vbTextCompare)
str = Replace(str, "===", "", 1, -1, vbTextCompare)
replacetext = str
End Function