API HTTP Download

Criei uma nova versão do CDownload:

Objeto: UserControl
Nome: CDownload

'---------------------------------------------------------------------------------------------------------

'################################'
'                                '
'    Escrito por CODER_EXPERT    '
'    ------------------------    '
'                                '
'    alien.coder@hotmail.com     '
'################################'

'      31/08/2008 06:53 AM

Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Enum TMETHOD
  METHOD_WAIT = 0
  METHOD_PROCESSMESSAGE = 1
End Enum

Public Enum TDATAFORMAT
  BINARY_BYTE_FORMAT = 0
  STRING_FORMAT = 1
End Enum

Public Enum TDOWNLOADSTATE
  ISNOT = 0
  INPROGRESS = 1
  ISCOMPLETED = 3
  ISDOWNLOADERROR = 4
End Enum

Dim State      As TDOWNLOADSTATE
Dim DataFormat As TDATAFORMAT

Dim binData()   As Byte
Dim Data       As String

Dim ObjectName As String
Dim FileName   As String

Event ProgressDownload(BytesMax As Long, BytesRead As Long, sObjectName As String)
Event CompletedDownload(sData As Variant, sObjectName As String)
Event ErrorDownload(sObjectName As String)

Public Function getstate() As TDOWNLOADSTATE
  Select Case State
  Case TDOWNLOADSTATE.ISNOT
    getstate = State
  Case TDOWNLOADSTATE.INPROGRESS
    getstate = State
  Case TDOWNLOADSTATE.ISCOMPLETED
    getstate = State
    State = ISNOT
  Case TDOWNLOADSTATE.ISDOWNLOADERROR
    getstate = State
  End Select
End Function

Public Function GetObjectName() As String
  If State <> ISNOT Then _
    GetObjectName = ObjectName
End Function

Public Function GetDataToFile(FileName As String) As Boolean
On Local Error GoTo Trata_Erro

Dim lngFreeFile As Long
lngFreeFile = FreeFile

  If Trim(Data) <> Empty Then
    Open FileName For Output Access Write As #lngFreeFile
      Print #lngFreeFile, Data
    Close #lngFreeFile
  Else
    GetDataToFile = False
  End If

Exit Function

Trata_Erro:
GetDataToFile = False
End Function

Public Function GetDataToVar(Optional DataFormat As TDATAFORMAT = STRING_FORMAT) As Variant
On Local Error Resume Next
  Select Case DataFormat
  Case TDATAFORMAT.BINARY_BYTE_FORMAT
    GetDataToVar = binData
  Case TDATAFORMAT.STRING_FORMAT
    GetDataToVar = Data
  End Select
End Function

Public Function URLDownload(sURL As String, Optional sFileName As String, Optional Method As TMETHOD = METHOD_WAIT, Optional sObjectName As String) As Boolean
  If Left$(UCase(sURL), 7) <> UCase("http://") Then
    State = ISDOWNLOADERROR
    RaiseEvent ErrorDownload(ObjectName)
    Exit Function
  End If

  If sObjectName <> Empty Then _
    ObjectName = sObjectName

  If sFileName <> Empty Then _
    FileName = sFileName

  State = INPROGRESS
  AsyncRead sURL, 1

  If Method = METHOD_WAIT Then
    Do
      DoEvents
      Sleep 1

      If State = ISDOWNLOADERROR Then
        'Erro ao tentar baixar arquivo
        URLDownload = False
        Exit Function
      ElseIf State = ISCOMPLETED Then
        'Arquivo baixado com sucesso
        URLDownload = True
        Exit Function
      End If
    Loop
  Else
    'Prossegue verdadeiro
    URLDownload = True
  End If
End Function

Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
On Local Error GoTo Trata_Erro

Dim lngFreeFile As Long
lngFreeFile = FreeFile

Erase binData
Open AsyncProp.Value For Binary As #lngFreeFile
  'Obtém o arquivo em formato de String
  Data = Space(FileLen(AsyncProp.Value))
  Get #lngFreeFile, , Data

  'Obtém o arquivo em fomato binário
  ReDim binData(LOF(lngFreeFile) - 1)
  Get lngFreeFile, , binData
Close #lngFreeFile

If FileName <> Empty Then
  If Trim(Data) <> Empty Then
    Open FileName For Output Access Write As #lngFreeFile
      Print #lngFreeFile, Data
    Close #lngFreeFile

    State = ISCOMPLETED
    RaiseEvent CompletedDownload(Data, ObjectName)
  Else
    State = ISDOWNLOADERROR
    RaiseEvent ErrorDownload(ObjectName)
  End If
Else
  If Trim(Data) <> Empty Then
    State = ISCOMPLETED
    RaiseEvent CompletedDownload(Data, ObjectName)
  Else
    State = ISDOWNLOADERROR
    RaiseEvent ErrorDownload(ObjectName)
  End If
End If

On Local Error Resume Next
If Dir$(AsyncProp.Value, vbReadOnly Or vbHidden Or vbSystem) <> Empty Then
  SetAttr AsyncProp.Value, vbNormal
  Kill AsyncProp.Value
End If
On Local Error GoTo Trata_Erro

Exit Sub
Trata_Erro:

State = ISDOWNLOADERROR
RaiseEvent ErrorDownload(ObjectName)
End Sub

Private Sub UserControl_AsyncReadProgress(AsyncProp As AsyncProperty)
  State = INPROGRESS

  RaiseEvent ProgressDownload(AsyncProp.BytesMax, AsyncProp.BytesRead, ObjectName)
End Sub

'---------------------------------------------------------------------------------------------------------

* Como usá-la:
------------------

Private Sub Command1_Click()
Dim bDown As Boolean
'Faz o download do arquivo ou página da web e define um nome para o objeto
'Esse código também envia POST para o servidor
bDown = CDown.URLDownload("http://www.uol.com.br/", , METHOD_WAIT, "UOL_PAGE")

'Obtém o conteúdo em formato binário do arquivo
Dim File() As Byte
File = CDown.GetDataToVar(BINARY_BYTE_FORMAT)

'Obtém o conteúdo em formato string do arquivo
Dim sFile As String
sFile = CDown.GetDataToVar(STRING_FORMAT)

'Exibe conteúdo do arquivo
MsgBox sFile

'Exibe o nome do Objeto
MsgBox CDown.GetObjectName

'Grava o Download que está na memória para o HD
CDown.GetDataToFile "C:Content.txt"

'Obtém o estado do download
Dim retState As TDOWNLOADSTATE
retState = CDown.getstate

'Checa o estado do download
If retState = ISCOMPLETED Then
  MsgBox "Download Completado com sucesso"
ElseIf retState = ISDOWNLOADERROR Then
  MsgBox "Erro ao fazer download de arquivo"
End If
End Sub

* Exemplo mais simplificado:
---------------------------------

Dim bDown As Boolean
bDown = CDown.URLDownload("http://www.uol.com.br/")

If bDown Then
  MsgBox "Download completado com sucesso."

  MsgBox CDown.GetDataToVar(STRING_FORMAT)
Else
  MsgBox "Erro ao fazer download"
End If

* Estilo API URLDownloadToFile:
--------------------------------

CDown.URLDownload "http://www.uol.com.br/", "C:UOL_Page.txt"

* Outra forma de usar:
---------------------------

CDown.URLDownload "http://www.uol.com.br/", , METHOD_PROCESSMESSAGE

Dim retState As TDOWNLOADSTATE
retState = CDown.getstate

While retState <> ISCOMPLETED
  retState = CDown.getstate
  DoEvents
Wend

If retState = ISCOMPLETED Then
  MsgBox "Download Completado com sucesso"
ElseIf retState = ISDOWNLOADERROR Then
  MsgBox "Falha ao fazer download"
End If

MsgBox CDown.GetDataToVar(STRING_FORMAT)