Как закачать файл из Интернета

[tyomitch]

URLDownloadToFile
пример писать лень, может быть, утром напишу

[tyomitch]

На тебе пример. Другой бы пожалел...

Код: Выделить всё

Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Object, ByVal szURL As String, ByVal szFileName As String, ByVal dwResv As Long, ByVal lpfnCB As Object) As Long
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Const E_NOINTERFACE = &H80004002
Private Const E_NOTIMPL = &H80004001
Private Const S_OK = 0&
Private Const BINDF_RESYNCHRONIZE = &H200&
Private Declare Function IsEqualIID Lib "ole32" Alias "IsEqualGUID" (riid1 As GUID, riid2 As GUID) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, lpiid As GUID) As Long
Private Declare Function StringFromGUID2 Lib "ole32" (rguid As GUID, ByVal lpsz As Long, ByVal cchMax As Long) As Long
Private Declare Function SysAllocStringAPI Lib "oleaut32" Alias "SysAllocString" (ByVal pOlechar As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Const GMEM_FIXED = 0&
Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Const IIDSTR_IUnknown = "{00000000-0000-0000-C000-000000000046}"
Private IID_IUnknown As GUID
Private Const IIDSTR_IAuthenticate = "{79EAC9D0-BAF9-11CE-8C82-00AA004BA90B}"
Private IID_IAuthenticate As GUID
Private Const IIDSTR_IBindStatusCallback = "{79EAC9C1-BAF9-11CE-8C82-00AA004BA90B}"
Private IID_IBindStatusCallback As GUID
Private VTableAuth(3) As Long
Private VTable(10) As Long
Private Type AuthClass
   VTableAuth As Long
   RefCount As Long
End Type
Private Type BindClass
   VTable As Long
   Auth As AuthClass
End Type

Sub Main()
    URLDownloadToFile Nothing, "http://mix.web.ur.ru/msvbvm60.zip", "c:\msvbvm60.zip", 0, NewBind
End Sub


Private Function QueryInterface(This As BindClass, riid As GUID, lObj As Long) As Long
   If IsEqualIID(riid, IID_IUnknown) Or _
      IsEqualIID(riid, IID_IBindStatusCallback) Then

      lObj = VarPtr(This)
      This.Auth.RefCount = This.Auth.RefCount + 1

      QueryInterface = S_OK
   
   ElseIf IsEqualIID(riid, IID_IAuthenticate) Then
   
      lObj = VarPtr(This.Auth)
      This.Auth.RefCount = This.Auth.RefCount + 1

      QueryInterface = S_OK
   
   Else
   
      lObj = 0

      QueryInterface = E_NOINTERFACE
   End If
End Function

Private Function AddRef(This As BindClass) As Long
   This.Auth.RefCount = This.Auth.RefCount + 1
   AddRef = This.Auth.RefCount
End Function

Private Function Release(This As BindClass) As Long
   This.Auth.RefCount = This.Auth.RefCount - 1
   Release = This.Auth.RefCount

   If This.Auth.RefCount = 0 Then _
      GlobalFree VarPtr(This)
End Function


Private Function OnStartBinding(This As BindClass, ByVal dwReserved As Long, ByVal pib As Long) As Long
OnStartBinding = E_NOTIMPL
Debug.Print "OnStartBinding"
End Function

Private Function GetPriority(This As BindClass, pnPriority As Long) As Long
GetPriority = E_NOTIMPL
Debug.Print "GetPriority"
End Function

Private Function OnLowResource(This As BindClass, ByVal reserved As Long) As Long
OnLowResource = E_NOTIMPL
Debug.Print "OnLowResource"
End Function

Private Function OnProgress(This As BindClass, ByVal ulProgress As Long, ByVal ulProgressMax As Long, ByVal ulStatusCode As Long, ByVal szStatusText As Long) As Long
If ulProgressMax Then
    Debug.Print SysAllocString(szStatusText), Format(ulProgress / ulProgressMax, "00.00%"), "Status code: " & LookupStatus(ulStatusCode)
Else
    Debug.Print SysAllocString(szStatusText), "Status code: " & LookupStatus(ulStatusCode)
End If
OnProgress = S_OK
End Function

Private Function OnStopBinding(This As BindClass, ByVal hresult As Long, ByVal szError As Long) As Long
Debug.Print "Transfer complete, herror = " & Hex(hresult)
End Function

Private Function GetBindInfo(This As BindClass, grfBINDF As Long, ByVal pbindinfo As Long) As Long
grfBINDF = BINDF_RESYNCHRONIZE
GetBindInfo = S_OK
End Function

Private Function OnDataAvailable(This As BindClass, ByVal grfBSCF As Long, ByVal dwSize As Long, ByVal pformatetc As Long, ByVal pstgmed As Long) As Long
OnDataAvailable = E_NOTIMPL
Debug.Print "OnDataAvailable"
End Function

Private Function OnObjectAvailable(This As BindClass, riid As GUID, ByVal punk As Object) As Long
OnObjectAvailable = E_NOTIMPL
Debug.Print "OnObjectAvailable"
End Function


Private Function QueryInterfaceAuth(This As AuthClass, riid As GUID, lObj As Long) As Long
   If IsEqualIID(riid, IID_IUnknown) Or _
      IsEqualIID(riid, IID_IAuthenticate) Then

      lObj = VarPtr(This)
      This.RefCount = This.RefCount + 1

      QueryInterfaceAuth = S_OK
   
   ElseIf IsEqualIID(riid, IID_IBindStatusCallback) Then
   
      lObj = VarPtr(This) - 4
      This.RefCount = This.RefCount + 1

      QueryInterfaceAuth = S_OK
   
   Else
   

      lObj = 0

      QueryInterfaceAuth = E_NOINTERFACE
   End If
End Function

Private Function AddRefAuth(This As AuthClass) As Long
   This.RefCount = This.RefCount + 1
   AddRefAuth = This.RefCount
End Function

Private Function ReleaseAuth(This As AuthClass) As Long
   This.RefCount = This.RefCount - 1
   ReleaseAuth = This.RefCount

   If This.RefCount = 0 Then _
      GlobalFree VarPtr(This) - 4
End Function

Private Function Authenticate(This As AuthClass, phwnd As Long, pszUsername As Long, pszPassword As Long) As Long
    phwnd = GetDesktopWindow
    Authenticate = S_OK
End Function


Public Function NewBind() As Object
Dim Class As BindClass, lObjPtr As Long

   If VTable(0) = 0 Then

      IIDFromString StrPtr(IIDSTR_IUnknown), IID_IUnknown
      IIDFromString StrPtr(IIDSTR_IAuthenticate), IID_IAuthenticate
      IIDFromString StrPtr(IIDSTR_IBindStatusCallback), IID_IBindStatusCallback

      VTableAuth(0) = AddrOf(AddressOf QueryInterfaceAuth)
      VTableAuth(1) = AddrOf(AddressOf AddRefAuth)
      VTableAuth(2) = AddrOf(AddressOf ReleaseAuth)
      VTableAuth(3) = AddrOf(AddressOf Authenticate)
     
      VTable(0) = AddrOf(AddressOf QueryInterface)
      VTable(1) = AddrOf(AddressOf AddRef)
      VTable(2) = AddrOf(AddressOf Release)
      VTable(3) = AddrOf(AddressOf OnStartBinding)
      VTable(4) = AddrOf(AddressOf GetPriority)
      VTable(5) = AddrOf(AddressOf OnLowResource)
      VTable(6) = AddrOf(AddressOf OnProgress)
      VTable(7) = AddrOf(AddressOf OnStopBinding)
      VTable(8) = AddrOf(AddressOf GetBindInfo)
      VTable(9) = AddrOf(AddressOf OnDataAvailable)
      VTable(10) = AddrOf(AddressOf OnObjectAvailable)
   End If

   With Class
      .Auth.RefCount = 1
      .Auth.VTableAuth = VarPtr(VTableAuth(0))
      .VTable = VarPtr(VTable(0))
   End With

   lObjPtr = GlobalAlloc(GMEM_FIXED, LenB(Class))
   MoveMemory ByVal lObjPtr, Class, LenB(Class)
   MoveMemory NewBind, lObjPtr, 4
End Function

Private Function AddrOf(ByVal Addr As Long) As Long
    AddrOf = Addr
End Function

Private Function LookupStatus(ByVal ulStatusCode As Long) As String
LookupStatus = Choose(ulStatusCode, _
    "BINDSTATUS_FINDINGRESOURCE", "BINDSTATUS_CONNECTING", _
    "BINDSTATUS_REDIRECTING", "BINDSTATUS_BEGINDOWNLOADDATA", _
    "BINDSTATUS_DOWNLOADINGDATA", "BINDSTATUS_ENDDOWNLOADDATA", _
    "BINDSTATUS_BEGINDOWNLOADCOMPONENTS", "BINDSTATUS_INSTALLINGCOMPONENTS", _
    "BINDSTATUS_ENDDOWNLOADCOMPONENTS", "BINDSTATUS_USINGCACHEDCOPY", _
    "BINDSTATUS_SENDINGREQUEST", "BINDSTATUS_CLASSIDAVAILABLE", _
    "BINDSTATUS_MIMETYPEAVAILABLE", "BINDSTATUS_CACHEFILENAMEAVAILABLE", _
    "BINDSTATUS_BEGINSYNCOPERATION", "BINDSTATUS_ENDSYNCOPERATION", _
    "BINDSTATUS_BEGINUPLOADDATA", "BINDSTATUS_UPLOADINGDATA", _
    "BINDSTATUS_ENDUPLOADDATA", "BINDSTATUS_PROTOCOLCLASSID", _
    "BINDSTATUS_ENCODING", "BINDSTATUS_VERIFIEDMIMETYPEAVAILABLE", _
    "BINDSTATUS_CLASSINSTALLLOCATION", "BINDSTATUS_DECODING", _
    "BINDSTATUS_LOADINGMIMEHANDLER", "BINDSTATUS_CONTENTDISPOSITIONATTACH", _
    "BINDSTATUS_FILTERREPORTMIMETYPE", "BINDSTATUS_CLSIDCANINSTANTIATE", _
    "BINDSTATUS_IUNKNOWNAVAILABLE", "BINDSTATUS_DIRECTBIND", _
    "BINDSTATUS_RAWMIMETYPE", "BINDSTATUS_PROXYDETECTING", _
    "BINDSTATUS_ACCEPTRANGES", "BINDSTATUS_COOKIE_SENT", _
    "BINDSTATUS_COMPACT_POLICY_RECEIVED", "BINDSTATUS_COOKIE_SUPPRESSED", _
    "BINDSTATUS_COOKIE_STATE_UNKNOWN", "BINDSTATUS_COOKIE_STATE_ACCEPT", _
    "BINDSTATUS_COOKIE_STATE_REJECT", "BINDSTATUS_COOKIE_STATE_PROMPT", _
    "BINDSTATUS_COOKIE_STATE_LEASH", "BINDSTATUS_COOKIE_STATE_DOWNGRADE", _
    "BINDSTATUS_POLICY_HREF", "BINDSTATUS_P3P_HEADER", _
    "BINDSTATUS_SESSION_COOKIE_RECEIVED", "BINDSTATUS_PERSISTENT_COOKIE_RECEIVED", _
    "BINDSTATUS_SESSION_COOKIES_ALLOWED")
End Function

Private Function SysAllocString(ByVal pOlechar As Long) As String
    MoveMemory ByVal VarPtr(SysAllocString), SysAllocStringAPI(pOlechar), 4
End Function


[Sebas]

в VBNET это

New WebClient.DownloadFile("http://server/file","c:\myfile"))

[tyomitch]

' --------------------------------------------------------
' Execute method of Internet Transfer Control
' Made by: Mikael Цstberg, me@mikeeast.com
' Use Freely!
' --------------------------------------------------------

Фи! Ради скачки файла форму заводить - не круто.

[tyomitch]

--------------------
код предоставленный выше
вешает программу и комп вместе сней
если прервать загрузку файла
---------------------------------

Обновление!!

Доработка этого кода с возможностью прервать загрузку, по просьбам трудящихся, выложена на http://users.isnet.ru/tyomitch/test.rar

Спешу пояснить: это скорее proof-of-concept, чем реальный модуль для загрузки файлов. Hо он действительно работает, и не требует ни форм, ни дополнительных библиотек (в отличие от Internet Transfer Control). Если будет не лень - когда-нибудь доведу до ума.

[alibek]

Обновление!!

Шайтан
А откуда информацию брал? В MSDN нашел или под отладчиком смотрел?

[tyomitch]

В MSDN нашел, конечно.

[GSerg]

Гы гы гы

И этот чел мне говорил: "Посмотрел твою менюшку. Собственная реализация класса - ну, довольно круто. Т.е. мне непонятно, зачем нужно было самому реализовывать уже имеющуюся в VB6 функциональность, так что я подхожу к этому как к вариации "ActiveX-контрол без формы".

А сам?

[tyomitch]

В первый раз мне хотелось по приколу всё реализовать в одном модуле, чтобы скопипастить код в пост, а не аттачить архив.

А в этот раз просто было лень всё переделывать, когда всего-то надо было поправить одну строчку.

Я не сомневаюсь, что это криво. См. дизклеймер в http://bbs.vbstreets.ru/viewtopic.php?p=153781#153781

[ALX_2002]

2 Tyomitch & Gserg:

(Тихий забитый голос откуда то снизу )

О Боги.....Боги.... А вы иногда делаете паузы на то чтобы попить пива, похавать, по%;№ся в конце концов и просто отдохнуть ?....

Извиняйте, не в коему случае не в обиду сказано - как вам удаётся перелопачивать столько инфы и не сходить с ума ? Билл Гатес вместе с изговотовителями MSDN наверное столько не знают...

[tyomitch]

Спешу пояснить: это скорее proof-of-concept, чем реальный модуль для загрузки файлов. Hо он действительно работает, и не требует ни форм, ни дополнительных библиотек (в отличие от Internet Transfer Control). Если будет не лень - когда-нибудь доведу до ума.

В большей степени доведённая до ума версия выложена на http://bbs.vbstreets.ru/viewtopic.php?p=155323#155323