Public Declare Function InternetReadFile Lib "wininet.dll" _
    (ByVal hFile As Long, _
     ByRef lpBuffer As Any, _
     ByVal lNumBytesToRead As Long, _
     ByRef lNumberOfBytesRead As Long) As Long

Option Explicit

Private Const USER_AGENT = "WinInet Test" 'User_agentヘッダ(任意)

'InternetReadFile で一度に読み込むサイズ
Private Const WI_READ_READSIZE = 1024

'データを受け取るバッファサイズの初期値
'必ず WI_READ_READSIZE 以上のサイズを指定して下さい
Private Const WI_INITBUFSIZE = 32767

'----- GetHttpData -----
'HTTP上のデータを取得します。
'
'引数 strUrl
'   データを取得したいHTTPのアドレス(URL)を指定します。
'
'引数 bytRecvData()
'   受信したデータを格納するバッファを、Byte型配列で指定します。
'   ここに実際に受信したデータが格納されます。
'
'引数 strProxy
'   省略可能です。Proxyサーバーを経由してデータを送受信したい場合、
'   ここに "proxy.hoge.co.jp:8080" のような型式で指定します。
'   省略または "" を渡した場合、レジストリに登録されている
'   アクセス方法で送受信します。
'
'戻り値
'   成功した場合、読み込んだデータの総サイズが返ります。
'   失敗した場合、0 が返ります。
'
Private Function GetHttpData _
    (ByVal strUrl As String, _
     ByRef bytRecvData() As Byte, _
     Optional ByVal strProxy As String) As Long

 Dim lngInetHandle As Long 'インターネットハンドルを格納
 Dim lngUrlHandle As Long  'URLハンドルを格納
 Dim lngArraySize As Long  'データを受け取るバッファ bytRecvData のサイズ
 Dim lngRet As Long     'InternetReadFile の戻り値を格納
 Dim lngTotalRead As Long  '受信したデータの総サイズ 兼 バッファへのポインタ
 Dim lngReadSize As Long   '受信したデータのサイズ
 
    If Len(strUrl) = 0 Then Exit Function
 
    '経由するProxyサーバーが指定されている場合
    If Len(strProxy) Then
        'インターネットハンドルを作成
        lngInetHandle = InternetOpen(USER_AGENT, _
                                     INTERNET_OPEN_TYPE_PROXY, _
                                     strProxy, _
                                     vbNullString, _
                                     0)
    '経由するProxyサーバーが指定されていない場合
    Else
        'インターネットハンドルを作成
        lngInetHandle = InternetOpen(USER_AGENT, _
                                     INTERNET_OPEN_TYPE_PRECONFIG, _
                                     vbNullString, _
                                     vbNullString, _
                                     0)
    End If
    If lngInetHandle = 0 Then Exit Function '失敗したら関数を抜ける

    'URLハンドルを作成
    lngUrlHandle = InternetOpenUrl(lngInetHandle, _
                                   strUrl, _
                                   vbNullString, _
                                   0, _
                                   INTERNET_FLAG_RELOAD, _
                                   0)
    If lngUrlHandle = 0 Then GoTo CloseInetHandle '失敗したら CloseInetHandle に飛ぶ
    
    lngArraySize = WI_INITBUFSIZE - 1
    ReDim bytRecvData(lngArraySize) 'バッファの初期サイズを確保する
    
    Do
        '次回受信時、バッファのサイズをオーバーしてしまう危険性がある場合
        If (lngTotalRead + WI_READ_READSIZE) > lngArraySize Then
            'バッファサイズを WI_INITBUFSIZE バイト増やす
            lngArraySize = lngArraySize + WI_INITBUFSIZE
            ReDim Preserve bytRecvData(lngArraySize - 1)
        End If
        'インターネット上のデータを読み込む
        lngRet = InternetReadFile(lngUrlHandle, _
                                  bytRecvData(lngTotalRead), _
                                  WI_READ_READSIZE, _
                                  lngReadSize)
        lngTotalRead = lngTotalRead + lngReadSize '読み込んだ総サイズを計算
        '受信サイズが0、または読み込み失敗の場合、ループを抜ける
        If (lngReadSize = 0) Or (lngRet = 0) Then Exit Do
    Loop
    
    If lngTotalRead Then '実際にデータが読み込まれた場合
        '配列サイズを実サイズに削る
        ReDim Preserve bytRecvData(lngTotalRead - 1)
        GetHttpData = lngTotalRead '読み込んだバイト数を返す
    Else
        Erase bytRecvData '総受信サイズが 0 の場合、配列を消去
    End If
    
    Call InternetCloseHandle(lngUrlHandle) 'URLハンドルを閉じる

CloseInetHandle:

    Call InternetCloseHandle(lngInetHandle) 'インターネットハンドルを閉じる

End Function

Private Sub cmdGetInetData_Click()

 Dim lngSize As Long    'GetHttpData()の戻り値(受信サイズ)を格納する
 Dim bytArray() As Byte 'データを受け取るバッファ(Byte型配列)

    'txtUrl で指定したURLのデータを取得
    lngSize = GetHttpData(txtUrl.Text, bytArray(), txtProxy.Text)
    If lngSize Then
        '成功したら、バッファのデータをUnicodeに変換し txtRecvData に表示
        txtRecvData.Text = StrConv(bytArray, vbUnicode)
    End If

    Erase bytArray

End Sub

Declare Function InternetSetOption Lib "wininet.dll" Alias "InternetSetOptionA" _
    (ByVal hInternet As Long, _
     ByVal lOption As Long, _
     ByRef sBuffer As Any, _
     ByVal lBufferLength As Long) As Integer

Const INTERNET_OPTION_CONNECT_TIMEOUT = 2

Const INTERNET_OPTION_RECEIVE_TIMEOUT = 6

Const INTERNET_OPTION_SEND_TIMEOUT = 5

Const INTERNET_OPTION_CONNECT_RETRIES = 3

lngConnectTimeOut = 15 * 1000 '接続タイムアウト15秒
lngReceiveTimeOut = 30 * 1000 '受信タイムアウト30秒
Call InternetSetOption(lngInetHandle, INTERNET_OPTION_CONNECT_TIMEOUT, lngConnectTimeOut, LenB(lngConnectTimeOut))
Call InternetSetOption(lngInetHandle, INTERNET_OPTION_RECEIVE_TIMEOUT, lngReceiveTimeOut, LenB(lngReceiveTimeOut))

Option Explicit

Public Declare Function InternetCrackUrl Lib "wininet.dll" Alias "InternetCrackUrlA" _
    (ByVal lpszUrl As String, _
     ByVal dwUrlLength As Long, _
     ByVal dwFlags As Long, _
     ByRef lpUrlComponents As URL_COMPONENTS) As Long

Public Const ICU_ESCAPE = &H80000000                        '(un)escape URL characters
Public Const ICU_DECODE = &H10000000                        'use internal username & password

'----- URL_COMPONENTS 構造体 -----
Public Type URL_COMPONENTS
    dwStructSize As Long                                    'URL_COMPONENTS 構造体のサイズ(60)
    lpszScheme As String                                    'スキーム("http", "ftp" など)
    dwSchemeLength As Long                                  'lpszScheme のサイズ
    nScheme As Long                                         'スキームの種類。INTERNET_SCHEME 定数参照
    lpszHostName As String                                  'ホスト名("www.yahoo.co.jp" など)
    dwHostNameLength As Long                                'lpszHostName のサイズ
    nPort As Long                                           'ポート番号
    lpszUserName As String                                  'ユーザー名
    dwUserNameLength As Long                                'lpszUserName のサイズ
    lpszPassword As String                                  'パスワード
    dwPasswordLength As Long                                'lpszPassword のサイズ
    lpszUrlPath As String                                   'パス("/index.html" など)
    dwUrlPathLength As Long                                 'lpszUrlPath のサイズ
    lpszExtraInfo As String                                 'pointer to extra information (e.g. ?foo or #foo)
    dwExtraInfoLength As Long                               'lpszExtraInfo のサイズ
End Type

Public Const INTERNET_SCHEME_PARTIAL = -2
Public Const INTERNET_SCHEME_UNKNOWN = -1
Public Const INTERNET_SCHEME_DEFAULT = 0
Public Const INTERNET_SCHEME_FTP = 1
Public Const INTERNET_SCHEME_GOPHER = 2
Public Const INTERNET_SCHEME_HTTP = 3
Public Const INTERNET_SCHEME_HTTPS = 4
Public Const INTERNET_SCHEME_FILE = 5
Public Const INTERNET_SCHEME_NEWS = 6
Public Const INTERNET_SCHEME_MAILTO = 7
Public Const INTERNET_SCHEME_SOCKS = 8
Public Const INTERNET_SCHEME_FIRST = INTERNET_SCHEME_FTP
Public Const INTERNET_SCHEME_LAST = INTERNET_SCHEME_SOCKS

Private Const INTERNET_MAX_HOST_NAME_LENGTH = 256           'ホスト名の最大サイズ。以下同上(^^;
Private Const INTERNET_MAX_USER_NAME_LENGTH = 128
Private Const INTERNET_MAX_PASSWORD_LENGTH = 128
Private Const INTERNET_MAX_PORT_NUMBER_LENGTH = 5
Private Const INTERNET_MAX_PORT_NUMBER_VALUE = 65535
Private Const INTERNET_MAX_PATH_LENGTH = 2048
Private Const INTERNET_MAX_SCHEME_LENGTH = 32
Private Const INTERNET_MAX_URL_LENGTH = INTERNET_MAX_SCHEME_LENGTH + 3 + INTERNET_MAX_PATH_LENGTH
Private Const INTERNET_MAX_EXTRAINFO_LENGTH = 512           'wininet.h にはありませんが自分で追加しました

'----- GetUrlComponents 関数 Version 1.00 -----
'InternetCrackUrl() を呼び出し URL を分解します。
'
'引数 strUrl
'   分解の対象となる URL 文字列式を指定します。
'
'引数 ucUrlComponents
'   分解された URL の各要素を格納する URL_COMPONENTS 構造体を指定します。
'   関数が成功した場合、ucUrlComponents の各メンバに情報が格納されます。
'
'引数 lngFlags
'   省略可能です。URL の分解方法を指定します。この引数を省略すると、
'   ICU_ESCAPE の値が使用されます。
'
'戻り値
'   関数が成功した場合、True を返します。
'
'※ 注意事項 ※
'
'この関数では、URL 文字列に全角文字(Shift-JIS で 2 バイトになる文字)が
'使用された場合のことは考慮しておりません。もし使用された場合、
'ucUrlComponents の文字列型メンバに格納される文字列が不正なものに
'なってしまいます。もし全角文字が使用される可能性がある場合は、
'後半の Left$ 関数を、拙作の TrimNull 関数などに置き換えるなどして
'変更した上でお使い下さい。
'
'TrimNull - http://www.geocities.co.jp/SilkRoad/4511/vb/kowaza.htm#trimnull
'
Public Function GetUrlComponents _
    (ByRef strUrl As String, _
     ByRef ucUrlComponents As URL_COMPONENTS, _
     Optional ByVal lngFlags As Long = ICU_ESCAPE) As Boolean

    If Len(strUrl) = 0 Then Exit Function                                       'URL 文字列が 0 文字の場合、関数を抜ける
    
    With ucUrlComponents                                                        'URL_COMPONENTS 構造体の各メンバの情報を設定
        .dwStructSize = LenB(ucUrlComponents)                                   'URL_COMPONENTS のサイズを設定(60 バイト)
        .dwSchemeLength = INTERNET_MAX_SCHEME_LENGTH                            'dwSchemeLength を INTERNET_MAX_SCHEME_LENGTH に設定
        .lpszScheme = String$(.dwSchemeLength, vbNullChar)                      'lpszScheme を dwSchemeLength 個の NULL で埋める
        .dwHostNameLength = INTERNET_MAX_HOST_NAME_LENGTH                       '以下同上(^^;
        .lpszHostName = String$(.dwHostNameLength, vbNullChar)
        .dwUserNameLength = INTERNET_MAX_USER_NAME_LENGTH
        .lpszUserName = String$(.dwUserNameLength, vbNullChar)
        .dwPasswordLength = INTERNET_MAX_PASSWORD_LENGTH
        .lpszPassword = String$(.dwPasswordLength, vbNullChar)
        .dwUrlPathLength = INTERNET_MAX_PATH_LENGTH
        .lpszUrlPath = String$(.dwUrlPathLength, vbNullChar)
        .dwExtraInfoLength = INTERNET_MAX_EXTRAINFO_LENGTH
        .lpszExtraInfo = String$(.dwExtraInfoLength, vbNullChar)
    End With

    If InternetCrackUrl(strUrl, Len(strUrl), lngFlags, ucUrlComponents) Then    'InternetCrackUrl() が成功した場合
        With ucUrlComponents
            .lpszScheme = Left$(.lpszScheme, .dwSchemeLength)                   'lpszScheme の余分な部分を削り再格納
            .lpszHostName = Left$(.lpszHostName, .dwHostNameLength)             '以下同上(^^;;
            .lpszUserName = Left$(.lpszUserName, .dwUserNameLength)
            .lpszPassword = Left$(.lpszPassword, .dwPasswordLength)
            .lpszUrlPath = Left$(.lpszUrlPath, .dwUrlPathLength)
            .lpszExtraInfo = Left$(.lpszExtraInfo, .dwExtraInfoLength)
        End With
        GetUrlComponents = True                                                 'True を返す
    End If

End Function