'-----------------------------------------------------------------------------------------
' エクセル VBA で HTML ファイルを URL を指定して読み込む関数
' 標準モジュールにこの内容を書いて、マクロ Test??? を実行すると読み込まれる
' ワークシートに =DownloadUTF8("http://www.yahoo.co.jp/") のように書いても
' セルに読み込むことかできる。
' coded by 和田維作 2009/5
'-----------------------------------------------------------------------------------------


'-----------------------------------------------------------------------------------------
' インターネット関連の Win32API 関数の宣言
Declare Function InternetOpenA Lib "wininet.dll" (ByVal a As String, ByVal b As Long, _
    ByVal c As String, ByVal d As String, ByVal e As Long) As Long
Declare Function InternetOpenUrlA Lib "wininet.dll" (ByVal a As Long, ByVal b As String, _
    ByVal c As String, ByVal d As Long, ByVal e As Long, ByVal f As Long) As Long
Declare Function InternetReadFile Lib "wininet.dll" (ByVal a As Long, ByRef b As Any, _
    ByVal c As Long, ByRef d As Long) As Long
Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal a As Long) As Long

'-----------------------------------------------------------------------------------------
' 指定した Url をダウンロードして string として返す。エラーが起きたら空文字列を返す
' Shift-JIS のみに対応。改行文字は chr(10) になる
Public Function DownloadSJIS(Url As String) As String
    Const BUF_SIZE = 4096: Static Buf(BUF_SIZE - 1) As Byte
    Dim hInet, hUrl, RetVal, BytesRead, i, c As Long: Dim r As String

    DownloadSJIS = "": r = "": c = 0
    hInet = InternetOpenA(vbNullString, 0, vbNullString, vbNullString, 0)
    If hInet = 0 Then Exit Function
    hUrl = InternetOpenUrlA(hInet, Url, vbNullString, 0, &H80000000, 0)
    If hUrl = 0 Then
        InternetCloseHandle hInet
        Exit Function
    End If
    Do
        RetVal = InternetReadFile(hUrl, Buf(0), BUF_SIZE, BytesRead)
        If RetVal = 0 Or BytesRead = 0 Then Exit Do
        For i = 0 To BytesRead - 1
            If c >= 256 Then
                r = r + Chr(c + Buf(i)):
                c = 0
            Else
                c = Buf(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
    Loop
    InternetCloseHandle hUrl
    InternetCloseHandle hInet
    DownloadSJIS = r
End Function

'-----------------------------------------------------------------------------------------
' 指定した Url をダウンロードして string として返す。エラーが起きたら空文字列を返す
' Euc-jp のみに対応。改行文字は chr(10) になる
Public Function DownloadEUC(Url As String) As String
    Const BUF_SIZE = 4096: Static Buf(BUF_SIZE - 1) As Byte
    Dim hInet, hUrl, RetVal, BytesRead, i, c As Long: Dim r As String

    DownloadEUC = "": r = "": c = -1
    hInet = InternetOpenA(vbNullString, 0, vbNullString, vbNullString, 0)
    If hInet = 0 Then Exit Function
    hUrl = InternetOpenUrlA(hInet, Url, vbNullString, 0, &H80000000, 0)
    If hUrl = 0 Then
        InternetCloseHandle hInet
        Exit Function
    End If
    Application.ScreenUpdating = False
    Do
        RetVal = InternetReadFile(hUrl, Buf(0), BUF_SIZE, BytesRead)
        If RetVal = 0 Or BytesRead = 0 Then Exit Do
        For i = 0 To BytesRead - 1
            If c <> -1 Then
                c = c + Buf(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 = Buf(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
    Loop
    InternetCloseHandle hUrl
    InternetCloseHandle hInet
    DownloadEUC = r
End Function


'-----------------------------------------------------------------------------------------
' 指定した Url をダウンロードして string として返す。エラーが起きたら空文字列を返す
' utf-8 のみに対応。改行文字は chr(10) になる
Public Function DownloadUTF8(Url As String) As String
    Const BUF_SIZE = 4096: Static Buf(BUF_SIZE - 1) As Byte
    Dim hInet, hUrl, RetVal, BytesRead, i, c, k As Long: Dim r As String

    DownloadUTF8 = "": r = "": c = 0: k = 0
    hInet = InternetOpenA(vbNullString, 0, vbNullString, vbNullString, 0)
    If hInet = 0 Then Exit Function
    hUrl = InternetOpenUrlA(hInet, Url, vbNullString, 0, &H80000000, 0)
    If hUrl = 0 Then
        InternetCloseHandle hInet
        Exit Function
    End If
    Do
        RetVal = InternetReadFile(hUrl, Buf(0), BUF_SIZE, BytesRead)
        If RetVal = 0 Or BytesRead = 0 Then Exit Do
        For i = 0 To BytesRead - 1
            If k = 0 Then
                c = Buf(i)
                If c < 128 Then
                    r = r & Chr(c)
                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 Do
                End If
            Else
                If (Buf(i) And &HC0) <> &H80 Then
                    Exit Do
                End If
                k = k - 1
                c = (c * 64) + (Buf(i) 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
    Loop
    InternetCloseHandle hUrl
    InternetCloseHandle hInet
    DownloadUTF8 = r
End Function


'-----------------------------------------------------------------------------------------
' 指定した Url をダウンロードして string として返す。エラーが起きたら空文字列を返す
' utf-16 のみに対応。改行文字は chr(10) になる
Public Function DownloadUTF16(Url As String) As String
    Const BUF_SIZE = 4096: Static Buf(BUF_SIZE - 1) As Byte
    Dim hInet, hUrl, RetVal, BytesRead, i, c As Long: Dim r As String

    DownloadUTF16 = "": r = "": b = 0
    hInet = InternetOpenA(vbNullString, 0, vbNullString, vbNullString, 0)
    If hInet = 0 Then Exit Function
    hUrl = InternetOpenUrlA(hInet, Url, vbNullString, 0, &H80000000, 0)
    If hUrl = 0 Then
        InternetCloseHandle hInet
        Exit Function
    End If
    RetVal = InternetReadFile(hUrl, Buf(0), BUF_SIZE, BytesRead)
    If BytesRead >= 2 And RetVal <> 0 Then
        If Buf(0) = &HFF And Buf(1) = &HFE Then
            i = 2
            Do
                For i = i To BytesRead - 1
                    r = r & ChrB(Buf(i))
                Next i
                RetVal = InternetReadFile(hUrl, Buf(0), BUF_SIZE, BytesRead)
                If RetVal = 0 Or BytesRead = 0 Then Exit Do
                i = 0
            Loop
        Else
            If Buf(0) <> &HFE Or Buf(1) <> &HFF Then i = 0 Else i = 2
            c = -1
            Do
                For i = i To BytesRead - 1
                    If c = -1 Then
                        c = Buf(i)
                    Else
                        r = r & ChrB(Buf(i)) & ChrB(c)
                        c = -1
                    End If
                Next i
                RetVal = InternetReadFile(hUrl, Buf(0), BUF_SIZE, BytesRead)
                If RetVal = 0 Or BytesRead = 0 Then Exit Do
                i = 0
            Loop
        End If
    End If
    InternetCloseHandle hUrl
    InternetCloseHandle hInet
    DownloadUTF16 = r
End Function

'-----------------------------------------------------------------------------------------
' セル A1 に、引数で指定した .html ファイルの内容を書き出す例
Public Sub TestSJIS()
    Columns("A:A").ColumnWidth = 120
    Cells(1, 1) = DownloadSJIS("http://www001.upp.so-net.ne.jp/isaku/tips/")
End Sub

Public Sub TestEUC()
    Columns("A:A").ColumnWidth = 120
    Cells(1, 1) = DownloadEUC("http://weather.yahoo.co.jp/weather/")
End Sub

Public Sub TestUTF8()
    Columns("A:A").ColumnWidth = 120
    Cells(1, 1) = DownloadUTF8("http://www.yahoo.co.jp/")
End Sub

Public Sub TestUTF16LE()
    Columns("A:A").ColumnWidth = 120
    Cells(1, 1) = DownloadUTF16("http://www001.upp.so-net.ne.jp/isaku/tips/utf16LE.html")
End Sub

Public Sub TestUTF16BE()
    Columns("A:A").ColumnWidth = 120
    Cells(1, 1) = DownloadUTF16("http://www001.upp.so-net.ne.jp/isaku/tips/utf16BE.html")
End Sub

Public Sub TestUTF16NB()
    Columns("A:A").ColumnWidth = 120
    Cells(1, 1) = DownloadUTF16("http://www001.upp.so-net.ne.jp/isaku/tips/utf16NB.html")
End Sub