HttpAccess

使い方

TODO: 使用例を記述

コード

Option Explicit

Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal Agent As String, ByVal AccessType As Long, ByVal ProxyName As String, ByVal ProxyBypass As String, ByVal Flags As Long) As Long
Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal InternetSession As Long, ByVal Url As String, ByVal Headers As String, ByVal HeadersLength As Long, ByVal Flags As Long, ByVal Context As Long) As Long
Declare Function InternetReadFile Lib "wininet.dll" (ByVal File As Long, ByRef Buffer As Any, ByVal NumBytesToRead As Long, ByRef NumberOfBytesRead As Long) As Long
Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal Inet As Long) As Long

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Const INTERNET_OPEN_TYPE_DIRECT = 1
Const INTERNET_OPEN_TYPE_PROXY = 3
Const INTERNET_INVALID_PORT_NUMBER = 0

Const INTERNET_FLAG_ASYNC = &H10000000
Const INTERNET_FLAG_FROM_CACHE = &H1000000
Const INTERNET_FLAG_OFFLINE = &H1000000

Const INTERNET_FLAG_RELOAD = &H80000000
Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Const INTERNET_FLAG_NO_AUTO_REDIRECT = &H200000
Const INTERNET_FLAG_PRAGMA_NOCACHE = &H100
 
' インターネットハンドル保存用
Private InetHandle As Long
Private UrlHandle As Long

'-------------------------------------------------------------------------------
'   Public Method
'-------------------------------------------------------------------------------
Public Sub DownloadText(ByRef Url As String, ByRef Text() As Byte)
    
    ' データ保存用
    Dim ReadData() As Byte
    Dim ReadSize As Long
    Dim GetSize As Long
    
    If OpenHttpFile(Url) = True Then
    
        ReDim ReadData(1023)
        ReadSize = GetHttpFile(ReadData())
        
        Do Until ReadSize = 0
            GetSize = GetSize + ReadSize
            ReDim Preserve Text(GetSize)
            Call CopyMemory(Text(GetSize - ReadSize), ReadData(0), ReadSize)
        
            ReadSize = GetHttpFile(ReadData())
        Loop
    End If
    
    ' 閉じる
    CloseHttpFile

End Sub

Public Sub ToSjis(ByRef Text() As Byte, Optional Charset As String = "EUC-JP")

    Dim Stm As ADODB.Stream
    Dim Str As String

    Set Stm = New ADODB.Stream
    Stm.Open

    ' バイナリモードで書き込み
    Stm.Type = adTypeBinary
    Stm.Write Text

    ' モードを指定キャラセットにして読み込み
    Stm.Position = 0
    Stm.Type = adTypeText
    Stm.Charset = Charset
    Text = Stm.ReadText(adReadAll)

    ' Stream オブジェクトの解放
    Stm.Close
    Set Stm = Nothing
    
End Sub

Public Function EncodeText(ByVal Url As String) As String

    Dim ScriptControl As Object
    Set ScriptControl = CreateObject("ScriptControl")
    ScriptControl.Language = "JScript"
    
    Dim CodeObject As Object
    Set CodeObject = ScriptControl.CodeObject
    
    EncodeText = CodeObject.encodeURIComponent(Url)

End Function

'-------------------------------------------------------------------------------
'   Private Method
'-------------------------------------------------------------------------------
Private Function OpenHttpFile(ByRef Url As String) As Boolean
    
    ' インターネットハンドル取得
    InetHandle = InternetOpen("Sample", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)

    ' 失敗したら抜ける
    If InetHandle = 0 Then
        OpenHttpFile = False
        Exit Function
    End If

    ' Url ハンドル取得
    UrlHandle = InternetOpenUrl(InetHandle, Url, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
    
    ' 失敗の時
    If UrlHandle = 0 Then
        InternetCloseHandle InetHandle
        OpenHttpFile = False
        Exit Function
    End If

    OpenHttpFile = True

End Function

Private Function GetHttpFile(ByRef Buffer() As Byte) As Long
    
    Dim Ret As Long
    Dim ReadSize As Long

    Ret = InternetReadFile(UrlHandle, Buffer(0), 1024, ReadSize)
    If (Ret = 0) Or (ReadSize = 0) Then
        GetHttpFile = 0
    Else
        GetHttpFile = ReadSize
    End If

End Function

Private Sub CloseHttpFile()

    InternetCloseHandle UrlHandle
    InternetCloseHandle InetHandle

End Sub

  • 最終更新:2015-09-30 21:06:01

このWIKIを編集するにはパスワード入力が必要です

認証パスワード