Outlook Express や Windows Mail で消えてしまった添付ファイルを取り出す (WINMAIL.DAT をデコードする) スクリプト

Outlook を使用して送信されたメールを Outlook Express や Windows Mail で受信すると、添付ファイルがまったく見えなくなるという現象が発生します。
これは、Outlook で TNEF と呼ばれるフォーマットにより、添付ファイルなどが WINMAIL.DAT にエンコードされてメッセージが送信されたため発生するもので、回避策としては送信元の Outlook の設定で TNEF を使わなくしてもらうというものになります。しかし、相手がお客様だったりした場合、受信者側でそのようなことをお願いするのは難しいという場合もあるかもしれません。
そこで、Outlook Express や Windows メールで受信してしまった WINMAIL.DAT 付きのメールから添付ファイルを取り出すことができるようにするスクリプトを作ってみました。
このスクリプトではコマンドラインで指定された EML ファイルから WINMAIL.DAT のデータをデコードし、ファイル名に "-decoded" をつけた新しい EML ファイルを生成します。例えば、c:\temp\test.eml というファイルをコマンドラインで指定すると、c:\temp\test-decoded.eml というファイルを生成します。
この生成された EML ファイルを開くと通常のメールと同様に添付ファイルが取り出せます。
使い方は以下のとおりです。

1. Outlook Express などで受信した添付ファイルがなくなったメッセージをデスクトップなどに EML ファイルとして保存します。
2. 保存した EML ファイルを後述のスクリプトファイルにドラッグアンドドロップします。(Outlook Express から直接スクリプトファイルにドラッグアンドドロップはできません。)
3. EML ファイルと同じフォルダに作成された -decoded.eml ファイルを開きます。
4. 添付ファイルを取り出します。

EML ファイルから直接ファイルをディスクに書き込むことも検討したのですが、スクリプトではバイナリデータの書き込みができず、かといって Visual Basic 2005 を使ったりするのは敷居が高いと思われたので、バイナリデータを BASE64 でテキストとして EML ファイルに書き込むという方法をとりました。
なお、ファイル名はシフト JIS 限定ですので、他の言語のファイル名が使われている場合、文字化けなどが発生する可能性があります。

下記のスクリプトをメモ帳などを使って DecodeWinMail.vbs というような名前で保存して使用してください。

'
'    DecodeWinMail.vbs - ここをトリプルクリックでスクリプト全体を選択できます。
'
'    WINMAIL.DAT ファイルが添付された EML ファイルを通常の MIME フォーマットに変換
'
Option Explicit
' 定数定義
'   Base64 の文字マッピング
Const BASE64DIGITS = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Const BASE64BUFLEN = 57 ' = 76/4*3
'   MIME 処理フェーズ
Const MIME_HEADER = 0
Const MIME_FIND_BOUNDARY = 1
Const MIME_PART_HEADER = 2
Const MIME_TO_LAST = 3
'
Const TemporaryFolder = 2
' グローバル変数
Dim abReadBuffer(64) 'As Byte
Dim lPtr 'As Long
Dim lReadSize 'As Long
Dim objFSO 'As FileSystemObject
Dim objShell 'As WShShell
' コマンドラインの指定があったら
If WScript.Arguments.Count > 0 Then
    ' ファイル名を指定してデコード開始
    DecodeMain WScript.Arguments.Item(0)
Else
    ' ファイル名指定が無ければ使用方法を表示
    WScript.Echo "使用方法: decodewinmail.vbs [eml ファイル名]"
End If
'
' デコード処理のメインループ
'
Sub DecodeMain(ByVal strFileName)
    Dim stmRead 'As TextStream
    Dim stmWrite 'As TextStream
    Dim iPhase 'As Integer
    Dim strLine 'As String
    Dim strBoundary 'As String
    Dim strHeader 'As String
    ' FileSystemObject の生成
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' WshShell の生成
    Set objShell = CreateObject("WScript.Shell")
    ' eml ファイル以外が指定されたら終了
    If Instr(strFileName, ".eml") = 0 Then Exit Sub
    ' コマンドラインで指定されたファイルを読み取りオープン
    Set stmRead = objFSO.OpenTextFile(strFileName)
    ' 書き込むファイルのファイル名は拡張子の前に -decoded をつけたものとする
    Set stmWrite = objFSO.CreateTextFile(Replace(strFileName,".eml","-decoded.eml",1,-1,1),True)
    ' ヘッダの読み取りから開始
    iPhase = MIME_HEADER
    While Not stmRead.AtEndOfStream
        strLine = stmRead.ReadLine
        Select Case iPhase
            Case MIME_HEADER
                ' ヘッダ中に boundary 指定が現れたら
                If Instr(strLine,"boundary=") > 0 Then
                    strBoundary = Mid(strLine, Instr(strLine,"""")+1)
                    strBoundary = "--" & Left(strBoundary, Instr(strBoundary,"""")-1)
                    ' 次の boundary を検索するフェーズに移行
                    iPhase = MIME_FIND_BOUNDARY
                End If
                stmWrite.WriteLine strLine
            Case MIME_FIND_BOUNDARY
                ' 指定された boundary 文字列が現れたら
                If strLine = strBoundary Then
                    strHeader = ""
                    ' MIME サブパートのヘッダの処理の開始
                    iPhase = MIME_PART_HEADER
                End If
                stmWrite.WriteLine strLine
            Case MIME_PART_HEADER
                ' 改行のみの行はヘッダの終わりを意味する
                If strLine = "" Then
                    ' Content-Type が application/ms-tnef だったら
                    If Instr(strHeader,"Content-Type: application/ms-tnef") >= 1 Then
                        ' TNEF のデコード
                        DecodeTnef stmRead, stmWrite, strBoundary
                        ' 以降のデータはそのまま書き込み
                        iPhase = MIME_TO_LAST
                    Else
                        ' TNEF でなければヘッダをそのまま書き込んで次の boundary まで書き込み
                        stmWrite.WriteLine strHeader
                        iPhase = MIME_FIND_BOUNDARY
                    End If
                Else
                    ' ヘッダはまとめて書き込む
                    strHeader = strHeader & strLine & vbCrLf
                End If
            Case MIME_TO_LAST
                ' 最後までそのままコピー
                stmWrite.WriteLine strLine
        End Select
    Wend
End Sub
'
'  TNEF のデコード
'
Sub DecodeTnef(ByVal stmRead, ByVal stmWrite, ByVal strBoundary)
    Dim abBuf(11) 'As Byte
    Dim iLen 'As Integer
    Dim abFileName() 'As Byte
    Dim strFileName 'As String
    Dim i 'As Integer
    Dim cAttach 'As Integer
    Dim iReadSize 'As Integer
    Dim abData(64)
    Dim bHeader ' As Boolean
    Dim strTempName ' As String
    Dim stmTemp ' As TextStream
    ' グローバル変数の初期化
    lPtr = 0
    lReadSize = 0
    ' 先頭 4 バイトを空読み込み
    If Base64ReadByte(stmRead, abBuf, 4, False) < 4 Then
        Exit Sub
    End IF
    '
    cAttach = 0
    bHeader = False
    Set stmTemp = Nothing ' データとヘッダが逆になった場合の一時ストリーム
    ' 11 バイトのデータヘッダを読み込み
    While Base64ReadByte(stmRead, abBuf, 11, True) = 11
        ' データの長さの取得
        iLen = ((((abBuf(10) * 256) + abBuf(9)) * 256) + abBuf(8)) * 256 + abBuf(7)
        ' 02 10 は添付ファイル名
        If abBuf(2) = 2 And abBuf(3) = &h10 Then
            ' ファイルが 2 つ目以降なら Boundary を書き込み
            If cAttach > 0 Then
                stmWrite.WriteLine strBoundary
            End If
            ReDim abFileName(iLen)
            ' ファイル名をバイナリで取得
            If Base64ReadByte(stmRead, abFileName, iLen, True) < iLen Then
                Exit Sub
            End If
            ' ファイル名をバイナリからテキストに変換 (SJIS のみ対応)
            strFileName = ""
            For i=0 To iLen-1
                If (abFileName(i) >= &h80 And abFileName(i) <= &h9f) Or abFileName(i) >= &he0 Then
                    strFileName = strFileName & Chr(abFileName(i) * 256 + abFileName(i+1))
                    i = i + 1
                ElseIf abFileName(i) <> 0 Then
                    strFileName = strFileName & Chr(abFileName(i))
                End If
            Next
            ' 添付ファイルのヘッダを書き込み
            stmWrite.WriteLine "Content-Disposition: attachment; filename=""" & strFileName & """"
            stmWrite.WriteLine "Content-Transfer-Encoding: base64"
            stmWrite.WriteLine "Content-Type: application/octet-stream;name=""" & strFileName & """" & vbCrLf
            If stmTemp Is Nothing Then ' 一時ストリームがなければヘッダ書き込みフラグをオン
                bHeader = True
            Else ' 一時ストリームがあったら内容をコピー
                stmWrite.WriteLine stmTemp.ReadAll()
                stmTemp.Close
                Set stmTemp = Nothing
                ' 一時ストリームを削除
                objFSO.DeleteFile strTempName
                bHeader = False
            End If
        ' 02 0f は添付ファイルのデータ
        ElseIf abBuf(2) = 2 And abBuf(3) = &h0f Then
            If bHeader Then ' ヘッダ出力済みならそのまま書き込み
                Set stmTemp = stmWrite
            Else ' ヘッダがまだの場合は一時ストリームへ書き込み
                strTempName = objShell.ExpandEnvironmentStrings("%TEMP%\" & objFSO.GetTempName())
                Set stmTemp = objFSO.CreateTextFile(strTempName,True)
            End If
            ' 一度に読み取るデータサイズはエンコード後に 76 バイトとなる 57 バイト
            iReadSize = BASE64BUFLEN
            While iLen > 0
                If iLen < BASE64BUFLEN Then
                    iReadSize = iLen
                End If
                ' データを読み込み
                If Base64ReadByte(stmRead, abData, iReadSize, True) < 0 Then
                    Exit Sub
                End If
                ' Base64 で書き込み
                Base64Write stmTemp, abData, iReadSize
                iLen = iLen - iReadSize
            Wend
            ' 最後に改行のみを追加
            stmTemp.WriteLine
            If bHeader Then
                Set stmTemp = Nothing
            Else
                stmTemp.Close
                Set stmTemp = objFSO.OpenTextFile(strTempName)
            End If
            cAttach = cAttach + 1
        ' 02 10 と 02 0f 以外は無視
        Else
            If Base64ReadByte(stmRead, abBuf, iLen, False) < 0 Then
                Exit Sub
            End If
        End If
    Wend
End Sub
'
' Base64 のデータから指定されたバイト数を読み込み
'
Function Base64ReadByte(ByVal stmRead, ByRef abBuf, ByVal iLen, ByVal bReadReally)
    Dim iCopied 'As Integer
    Dim iCopyLen 'As Integer
    Dim i 'As Integer
    iCopied = 0
    While iCopied < iLen
        ' バッファの終わりにポインタがある
        If lPtr = lReadSize Then
            ' Base64 データの読み込み
            lReadSize = lReadSize + Base64Read(stmRead, abReadBuffer)
            ' データが読み込めなかった場合は -1 を返す
            If lPtr = lReadSize Then
                Base64ReadByte = -1
                Exit Function
            End If
        ' バッファに読み込んでいないデータがある
        Else
            If lPtr+iLen-iCopied > lReadSize Then
                iCopyLen = lReadSize - lPtr
            Else
                iCopyLen = iLen - iCopied
            End If
            If bReadReally Then
                For i=0 To iCopyLen - 1
                    abBuf(iCopied+i) = abReadBuffer((lPtr + i) Mod BASE64BUFLEN)
                Next
            End If
            iCopied = iCopied + iCopyLen
            lPtr = lPtr + iCopyLen
        End If
    Wend
    Base64ReadByte = iCopied
End Function
'
'   Base64 でデコードして読み込み
'
Function Base64Read(ByVal stmRead, ByRef abData)
'    On Error Resume Next
    Dim strText 'As String
    Dim i 'As Long
    Dim l 'As Long
    Dim j 'As Integer
    Dim dc(4) 'As Integer
    Dim lMax 'As Long
    Dim strDecode 'As String
    Dim dcMax 'As Long
    ' ファイルから 1 行読み込み
    strText = stmRead.ReadLine
    lMax = Len(strText)
    i = 0
    dcMax = 0
    While i * 4 < lMax
        l = i * 4 + 1
        For j = 0 To 3
            If l + j <= lMax Then
                dc(j) = InStr(1, BASE64DIGITS, Mid(strText, l + j, 1), vbBinaryCompare) - 1
            Else
                dc(j) = -1
            End If
        Next
        l = i * 3
        abData(l) = (dc(0) * &H4 Or (dc(1) And &H30) / &H10)
        dcMax = dcMax + 1
        If dc(2) >= 0 Then
            abData(l + 1) = ((dc(1) And &HF) * &H10 Or (dc(2) And &H3C) / &H4)
            dcMax = dcMax + 1
        End If
        If dc(3) >= 0 Then
            abData(l + 2) = ((dc(2) And &H3) * &H40 Or (dc(3) And &H3F))
            dcMax = dcMax + 1
        End If
        i = i + 1
    Wend
    ' デコードしたバイト数を返す
    Base64Read = dcMax
End Function
'
'  Base64 でエンコードしてファイルに書き込み
'
Sub Base64Write(ByVal stmWrite, ByVal abData, ByVal iSize)
'    On Error Resume Next
    Dim i 'As Long
    Dim j 'As Integer
    Dim c 'As Integer
    Dim ecMax 'As Integer
    Dim ec(3) 'As Integer
    Dim strEncoded 'As String
    '
    strEncoded = ""
    ecMax = 3
    For i = 0 To iSize-1 Step 3
        c = abData(i)
        ec(0) = Int(c / 4)
        ec(1) = (c And 3) * 16
        If i + 1 >= iSize Then
            c = 0
            ecMax = 1
        Else
            c = abData(i + 1)
        End If
        ec(1) = ec(1) Or Int(c / 16)
        ec(2) = (c And 15) * 4
        If i + 2 >= iSize Then
            c = 0
            If ecMax > 2 Then ecMax = 2
        Else
            c = abData(i + 2)
        End If
        ec(2) = ec(2) Or Int(c / 64)
        ec(3) = c And &H3F
        For j = 0 To ecMax
            strEncoded = strEncoded & Mid(BASE64DIGITS, ec(j) + 1, 1)
        Next
        If Len(strEncoded) >= 76 Then
            stmWrite.WriteLine strEncoded
            strEncoded = ""
        End If
    Next
    ' 最後の行を書き込み
    If strEncoded <> "" Then
        If Len(strEncoded) Mod 4 > 0 Then
            strEncoded = strEncoded & String(4 - (Len(strEncoded) Mod 4), "=")
        End If
        stmWrite.WriteLine strEncoded
    End If
End Sub