'------------------------------------------------------------------
' エクセル VBA でファイル名を指定して読み込む関数
' ワークシートに =ReadSJIS("Test.txt") のように
' 書いてもセルに読み込むことかできる。
' coded by 和田維作 2009/5
'------------------------------------------------------------------

Option Explicit
'------------------------------------------------------------------
' Shift-JIS のみに対応。改行文字は chr(10) になる
Public Function ReadSJIS(ByVal f As String) As String
    Dim r As String: Dim i, c, FileNo As Long: Dim s() As Byte
    If Left(f, 1) <> "\" And (Len(f) < 4 Or Mid(f, 2, 1) <> ":") Then
        f = ThisWorkbook.Path & "\" & f
    End If
    FileNo = FreeFile()
    Open f For Binary As #FileNo
    ReDim s(LOF(FileNo) - 1)
    Get #FileNo, , s
    Close (FileNo)
    c = 0: r = ""
    For i = 0 To UBound(s)
        If c >= 256 Then
            r = r & Chr(c + s(i))
            c = 0
        Else
            c = s(i)
            If c >= 160 And c <= 223 Then
                r = r & ChrB(c - 64)
                r = r & ChrB(255)
            ElseIf c > 128 And c < 253 Then
                c = c * 256
            Else
                If c <> 13 Then r = r & Chr(c)
            End If
        End If
    Next i
    ReadSJIS = r
End Function

'------------------------------------------------------------------
' utf-16 のみに対応。改行文字は chr(10) になる
Public Function ReadUTF16(ByVal f As String) As String
    Dim s, r As String: Dim i, FileNo As Long
    If Left(f, 1) <> "\" And (Len(f) < 4 Or Mid(f, 2, 1) <> ":") Then
        f = ThisWorkbook.Path & "\" & f
    End If
    FileNo = FreeFile()
    Open f For Binary As #FileNo
    s = InputB(LOF(FileNo), FileNo)
    Close (FileNo)
    If (AscW(s) And &HFFFF) = &HFEFF Then
        ReadUTF16 = Mid(s, 2)
        Exit Function
    End If
    If (AscW(s) And &HFFFF) = &HFFFE Then i = 3 Else i = 1
    For i = i To LenB(s) Step 2
        r = r & MidB(s, i + 1, 1) & MidB(s, i, 1)
    Next i
    ReadUTF16 = r
End Function

'------------------------------------------------------------------
' Euc-jp のみに対応。改行文字は chr(10) になる
Public Function ReadEUC(ByVal f As String) As String
    Dim i, c, FileNo As Long: Dim r As String: Dim s() As Byte
    If Left(f, 1) <> "\" And (Len(f) < 4 Or Mid(f, 2, 1) <> ":") Then
        f = ThisWorkbook.Path & "\" & f
    End If
    FileNo = FreeFile()
    Open f For Binary As #FileNo
    ReDim s(LOF(FileNo) - 1)
    Get #FileNo, , s
    Close (FileNo)
    r = "": c = -1
    For i = 0 To UBound(s)
        If c <> -1 Then
            c = c + s(i) - 128
            If c >= 3616 And c <= 3679 Then
                r = r & ChrB(c - 3520)
                r = r & ChrB(255)
            Else
                r = r & Evaluate("CHAR(" & c & ")")
            End If
            c = -1
        Else
            c = s(i)
            If c >= 128 Then
               c = (c - 128) * 256
            Else
               If c <> 13 Then r = r & Chr(c)
               c = -1
            End If
        End If
    Next i
    ReadEUC = r
End Function


'------------------------------------------------------------------
' utf-8 のみに対応。改行文字は chr(10) になる
Public Function ReadUTF8(ByVal f As String) As String
    Dim i, c, d, k, FileNo As Long: Dim r As String: Dim s() As Byte
    If Left(f, 1) <> "\" And (Len(f) < 4 Or Mid(f, 2, 1) <> ":") Then
        f = ThisWorkbook.Path & "\" & f
    End If
    FileNo = FreeFile()
    Open f For Binary As #FileNo
    ReDim s(LOF(FileNo))
    Get #FileNo, , s
    Close (FileNo)
    r = "": c = 0: k = 0
    For i = 0 To UBound(s)
        If k = 0 Then
            c = s(i)
            If c < 128 Then
                If c <> 13 Then
                    r = r & Chr(c)
                End If
            ElseIf (c And &HE0) = &HC0 Then
                c = c And &H1F
                k = 1
            ElseIf (c And &HF0) = &HE0 Then
                c = c And &HF
                k = 2
            ElseIf (c And &HF8) = &HF0 Then
                c = c And &H7
                k = 3
            ElseIf (c And &HFC) = &HF8 Then
                c = c And &H3
                k = 4
            ElseIf (c And &HFE) = &HFC Then
                c = c And &H1
                k = 5
            Else
                Exit For
            End If
        Else
            d = s(i)
            If (d And &HC0) <> &H80 Then
                Exit For
            End If
            k = k - 1
            c = (c * 64) + (d And &H3F)
            If k = 0 Then
                If c >= &H10000 Then
                    c = c - &H10000
                    r = r & ChrW(&HD800 + (c \ 1024))
                    r = r & ChrW(&HDC00 + (c Mod 1024))
                Else
                    If c <> &HFEFF Then
                        r = r & ChrW(c)
                    End If
                End If
            End If
        End If
    Next i
    ReadUTF8 = r
End Function