Option Explicit

 

'Created by SCINER: lenar2003@mail.ru

 

Private Const INTERNET_OPEN_TYPE_PRECONFIG  As Long = 0

Private Const INTERNET_OPEN_TYPE_DIRECT     As Long = 1

Private Const INTERNET_OPEN_TYPE_PROXY      As Long = 3

Private Const HTTP_QUERY_CONTENT_LENGTH     As Long = 5

Private Const INTERNET_FLAG_RELOAD          As Long = &H80000000

 

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _

(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Declare Function InternetOpen Lib "wininet.dll" Alias _

"InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, _

ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long

Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" _

(ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any, _

ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer

Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias _

"InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, _

ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long

Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias _

"HttpOpenRequestA" (ByVal hHttpSession As Long, ByVal sVerb As String, _

ByVal sObjectName As String, ByVal sVersion As String, ByVal sReferer As String, _

ByVal something As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long

Private Declare Function HttpSendRequest Lib "wininet.dll" Alias _

"HttpSendRequestA" (ByVal hHttpRequest As Long, ByVal sHeaders As String, _

ByVal lHeadersLength As Long, sOptional As Any, ByVal lOptionalLength As Long) As Integer

Private Declare Function InternetReadFile Lib "wininet.dll" _

(ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _

lNumberOfBytesRead As Long) As Integer

Private Declare Function InternetCloseHandle Lib "wininet.dll" _

(ByVal hInet As Long) As Integer

Private Declare Function InternetQueryDataAvailable Lib "wininet.dll" _

(ByVal hFile As Long, lpdwNumberOfBytesAvailable As Long, ByVal dwFlags As Long, _

ByVal dwContext As Long) As Long

 

Private Function HttpReadPage(ByVal Url As String) As String

    Dim vBuff  As String

    Dim vhOpen As Long

    Dim vhUrl  As Long

    Dim vSize  As Long

    Dim vRet   As Long

    vhOpen = InternetOpen("Mozilla/4.0", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)

    If vhOpen Then

        vhUrl = InternetOpenUrl(vhOpen, Url, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)

        If vhUrl Then

            If InternetQueryDataAvailable(vhUrl, vSize, 0, 0) Then

                If (vSize = 0) Then vSize = 4096

                vBuff = String(vSize, 0)

                Do

                  InternetReadFile vhUrl, vBuff, vSize, vRet

                  If (vRet = 0) Then Exit Do

                  HttpReadPage = HttpReadPage & VBA.Left$(vBuff, vRet)

                Loop

            End If

            InternetCloseHandle vhUrl

        End If

        InternetCloseHandle vhOpen

    End If

End Function

 

Function URLPicture(ByVal strURL As String) As StdPicture

 

  On Error GoTo 1

  Dim B() As Byte

 

  Dim FF As Long

  Dim lRet As Long

  Dim strTempPath As String

  

  B = StrConv(HttpReadPage(strURL), vbFromUnicode)

 

  strTempPath = VBA.Space$(260)

  GetTempPath 260, strTempPath

  If InStr(strTempPath, vbNullChar) > 0 Then strTempPath = VBA.Left$(strTempPath, _

                                             InStr(strTempPath, vbNullChar) - 1)

  strTempPath = strTempPath & "img_temp.bmp"

  

  FF = FreeFile

  Open strTempPath For Binary As #FF

    Put #FF, , B

  Close #FF

 

  Set URLPicture = LoadPicture(strTempPath)

  Exit Function

1:

  Set URLPicture = LoadPicture()

  End Function

 

Private Sub Form_Load()

  Image1 = URLPicture("http://img.yandex.ru/i/logo76x44.gif")

End Sub