Excel VBA読み込みで文字化けが

質問

Excel VBAにてメールデータを読み込むプログラムを組んでいます。
データの作り方は、
(1)Mozilla Thunderbirdでメールデータをtext形式で保存
(2)VBAにてtextデータを開く。

しかし読み込みを行うと、文字化けしたデータが表示されてしまいます。

どのように解決したらよいのでしょうか？
文字コード変換を行ってもダメでした。

Sub Read_mail_data()
Const cnsTITLE = "テキストファイル読み込み処理"
Const cnsFILTER = "全てのファイル (*.*),*.*"
Dim xlAPP As Application ' Applicationオブジェクト
Dim intFF As Integer ' FreeFile値
Dim strFileName As String ' OPENするファイル名(フルパス)
Dim vntFileName As Variant ' ファイル名受け取り用
Dim strREC As String ' 読み込んだレコード名
Dim GYO As Long ' 収容するセルの行
Dim lngREC As Long ' レコード件数カウンタ

' Applicationオブジェクト取得
Set xlAPP = Application
' 「ファイルを開く」のダイアログでファイル名の指定を受ける
xlAPP.StatusBar = "読み込むファイル名を指定して下さい。"
vntFileName = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, Title:=cnsTITLE)
' キャンセルされた場合はFalseが返るので以降の処理は行わない
If VarType(vntFileName) = vbBoolean Then Exit Sub
strFileName = vntFileName

' FreeFile値の取得(以降この値で入出力する)
intFF = FreeFile
' 指定ファイルをOPEN(入力モード)
Open strFileName For Input As #intFF
GYO = 1
' ファイルのEOF(End of File)まで繰り返す
Do Until EOF(intFF)
' レコード件数カウンタの加算
lngREC = lngREC + 1
xlAPP.StatusBar = "読み込み中です....(" & lngREC & "レコード目)"
' 改行までをレコードとして読み込む
Line Input #intFF, strREC
' 行を加算しA列にレコード内容を表示(先頭は2行目)
GYO = GYO + 1
' 文字コードを変換する
'StrConv(strREC, vbFromUnicode) = a
Cells(GYO, 1).Value = StrConv(strREC, vbFromUnicode)
Cells(GYO, 1).Value = StrConv(strREC, vbFromUnicode)
Cells(GYO, 1).Value = StrConv(strREC, vbFromUnicode)
Cells(GYO, 1).Value = StrConv(strREC, vbFromUnicode)
Cells(GYO, 1).Value = StrConv(strREC, vbFromUnicode)
Cells(GYO, 1).Value = StrConv(strREC, vbFromUnicode)
' セルにデータを書き込む
'Cells(GYO, 1).Value = strREC
Loop
' 指定ファイルをCLOSE
Close #intFF
xlAPP.StatusBar = False
' 終了の表示
MsgBox "ファイル読み込みが完了しました。 " & vbCr & "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE

End Sub

回答No.1

nicotinism · ベストアンサー

文字化けの原因が文字コードのためだと・・仮定して。
Ado.Stream で読み込んだらどうなりますかね。

Sub testAdoStream()
Dim objStrm As Object
Dim strTmp As String
Dim i As Integer
Const ReadLine As Integer = -2, ReadAll As Integer = -1
Set objStrm = CreateObject("ADODB.Stream")

With objStrm
.Charset = "ISO-2022-JP"
.LineSeparator = -1 'CR=13, LF=10, CRLF=-1
.Open
.LoadFromFile "D:\ThunderbirdMAIL.txt"
End With

Do Until objStrm.EOS
i = i + 1
Cells(i, 1) = objStrm.ReadText(ReadLine)
Loop
objStrm.Close: Set objStrm = Nothing
End Sub

なお、Charset の "ISO-2022-JP" はあてずっぽうです。
Thunderbird は使ったことが有りませんので、ここまで。

お礼

色々試して、ず～っと悩んでいましたが、おかげさまで
できました！本当にありがとうございます。