Option Explicit On 
Option Strict Off
Option Compare Binary


'=============================================================================================================
'
' cDownload1.vb
' -------------
'
' Created By  : Kevin Wilson
'
' Last Update : January 13, 2004
' Created On  : January 12, 2004
'
' VB Versions : MSXML 2.0  [MSXML.DLL]  (which is included in every version of MSIE later than 4.0)
'               VB.NET 1.1 (VS.NET 2003)
'
' Requires    : The .NET Framework v1.1
'
' Description : This class module makes it easy to download files and track the download progress in real time.
'
' Example Use :
'
'-------------------------------------------------------------------------------------------------------------
'
' Dim objDownload As New cDownload1("GET", True)
' If objDownload.DownloadFile("C:\AB_Demo_vb5.zip", "http://www.thevbzone.com/files/VisualBasic/AB_Demo_vb5.zip", sResponse, iErrNum, sErrSrc, sErrDesc) = False Then
'    MsgBox("An error occured occured while downloading the specified file:" & vbCrLf & vbCrLf & _
'           "Error Number = " & iErrNum & vbCrLf & _
'           "Error Source = " & sErrSrc & vbCrLf & _
'           "Error Description = " & sErrDesc & vbCrLf & vbCrLf & _
'           "Server Response = " & sResponse, MsgBoxStyle.OKOnly Or MsgBoxStyle.Exclamation, "  Error")
' Else
'    MsgBox("File successfully downloaded!", MsgBoxStyle.OKOnly Or MsgBoxStyle.Information, " ")
' End If
' objDownload = Nothing
'
'=============================================================================================================

Imports System
Imports MSXML
Imports Microsoft.VisualBasic
Imports System.Windows.Forms


Public Class cDownload1

#Region "Local Variable Declarations"

   Private m_RemotePath As String
   Private m_LocalPath As String
   Private m_RequestMethod As String
   Private m_OverwriteIfExists As Boolean
   Private m_blnCancel As Boolean

#End Region

#Region "Public Constructors"

   Public Sub New()

      m_RemotePath = ""
      m_LocalPath = ""
      m_OverwriteIfExists = True
      m_RequestMethod = "GET"

   End Sub

   Public Sub New(ByVal strRequestMethod As String, _
                  ByVal blnOverwriteIfExists As Boolean)

      m_RemotePath = ""
      m_LocalPath = ""
      m_OverwriteIfExists = blnOverwriteIfExists
      m_RequestMethod = strRequestMethod

   End Sub

#End Region

#Region "Public Deconstructors"

   Protected Overrides Sub Finalize()
      MyBase.Finalize()
   End Sub

#End Region

#Region "Public Property Declarations"

   Public Property OverwriteIfFilesExist() As Boolean
      Get
         Return m_OverwriteIfExists
      End Get
      Set(ByVal Value As Boolean)
         m_OverwriteIfExists = Value
      End Set
   End Property

   Public Property RequestMethod() As String
      Get
         Return m_RequestMethod
      End Get
      Set(ByVal Value As String)
         m_RequestMethod = Value
      End Set
   End Property

#End Region

#Region "Public Method Declarations"

   Public Overloads Function DownloadFile(ByVal strLocalFilePath As String, _
                                          ByVal strRemoteFilePath As String, _
                                          ByRef Return_ServerResponse As String, _
                                          ByRef Return_ErrNum As Integer, _
                                          ByRef Return_ErrSrc As String, _
                                          ByRef Return_ErrDesc As String) As Boolean

      Return DownloadFile(strLocalFilePath, strRemoteFilePath, m_RequestMethod, "", "", m_OverwriteIfExists, Return_ServerResponse, Return_ErrNum, Return_ErrSrc, Return_ErrDesc)

   End Function

   Public Overloads Function DownloadFile(ByVal strLocalFilePath As String, _
                                          ByVal strRemoteFilePath As String, _
                                          Optional ByVal strRequestMethod As String = "GET", _
                                          Optional ByVal strPageAuthName As String = "", _
                                          Optional ByVal strPageAuthPassword As String = "", _
                                          Optional ByVal blnOverwriteIfExists As Boolean = True, _
                                          Optional ByRef Return_ServerResponse As String = "", _
                                          Optional ByRef Return_ErrNum As Integer = 0, _
                                          Optional ByRef Return_ErrSrc As String = "", _
                                          Optional ByRef Return_ErrDesc As String = "") As Boolean
      On Error GoTo ErrorHandler

      Dim oXML As MSXML.XMLHTTPRequest
      Dim oXML_Err As MSXML.IXMLDOMParseError
      Dim abytReturn() As Byte
      Dim oStream As IO.FileStream
      Dim oBinary As IO.BinaryWriter
      Dim strDir As String

      ' Set default values
      Return_ServerResponse = ""
      Return_ErrNum = 0
      Return_ErrSrc = ""
      Return_ErrDesc = ""

      ' Check required params
      If Trim(strRemoteFilePath) = "" Then
         Return_ErrNum = -1
         Return_ErrSrc = "DownloadFile() >> Parameters"
         Return_ErrDesc = "No valid URL specified"
         Exit Function
      End If
      strRequestMethod = UCase(Trim(strRequestMethod))
      Select Case strRequestMethod
         Case "GET", "POST", "PUT", "PROPFIND" 'DO NOTHING
         Case Else : strRequestMethod = "GET"
      End Select

      ' If the file already exists, delete it
      If IO.File.Exists(strLocalFilePath) = True Then
         If blnOverwriteIfExists = True Then
            IO.File.Delete(strLocalFilePath)
         Else
            Return_ErrNum = -1
            Return_ErrSrc = "DownloadFile()"
            Return_ErrDesc = "File Already Exists"
            Exit Function
         End If
      End If

      ' If the directory doesn't exist, create it
      If InStr(strLocalFilePath, "\") > 0 Then
         strDir = Left(strLocalFilePath, InStrRev(strLocalFilePath, "\"))
         If IO.Directory.Exists(strDir) = False Then
            IO.Directory.CreateDirectory(strDir)
         End If
      End If

      ' Setup the XML HTTP request
      oXML = New MSXML.XMLHTTPRequest
      'oXML.setRequestHeader("Pragma", "no-cache")
      'oXML.setRequestHeader("Cache-Control", "no-cache, no-store, max-age=0")
      'oXML.setRequestHeader("Expires", "Mon, 26 Jul 1997 05:00:00 GMT")
      Call oXML.open(strRequestMethod, strRemoteFilePath, False, strPageAuthName, strPageAuthPassword)

      ' Make the request to the server
      Call oXML.send()

      ' Check if the request was successful
      If CheckOkToContinue(oXML.status, Return_ErrDesc) = True Then

         ' Get the response back in the form of a BYTE ARRAY
         abytReturn = oXML.responseBody

         ' Save the byte array to the specified file
         oStream = New IO.FileStream(strLocalFilePath, IO.FileMode.CreateNew, IO.FileAccess.Write)
         oBinary = New IO.BinaryWriter(oStream)
         oBinary.Write(abytReturn)
         oBinary.Flush()
         oBinary.Close()
         oBinary = Nothing
         oStream.Close()
         oStream = Nothing

         DownloadFile = True

         ' If an error occured on the server, return it's information
      Else
         DownloadFile = False
         Return_ErrNum = -1
         Return_ErrSrc = "MSXML.XMLHTTPRequest.send(..)"
         Return_ErrDesc = "Server returned the following error code : " & oXML.status & " [" & Return_ErrDesc & "]"
         Return_ServerResponse = oXML.responseText
      End If

      ' Clean up
      oXML = Nothing
      oXML_Err = Nothing
      Exit Function

ErrorHandler:

      Return_ErrNum = Err.Number
      Return_ErrSrc = Err.Source
      Return_ErrDesc = Err.Description
      If InStr(Return_ErrDesc, "Exception from HRESULT", CompareMethod.Text) > 0 Then
         Return_ErrDesc = Return_ErrDesc & "  [This error may have been caused by the server being unreachable or unresponsive]"
      End If
      Err.Clear()
      On Error Resume Next
      If Not oBinary Is Nothing Then
         oBinary.Close()
         oBinary = Nothing
      End If
      If Not oStream Is Nothing Then
         oStream.Close()
         oStream = Nothing
      End If
      oXML = Nothing
      oXML_Err = Nothing

   End Function

#End Region

#Region "Private Helper Functions"

   ' Get the server status code from the supplied server status
   Private Function CheckOkToContinue(ByVal lngStatus As Integer, ByRef Return_StatusDesc As String) As Boolean

      If lngStatus = 200 Then
         Return_StatusDesc = ""
         CheckOkToContinue = True
         Exit Function
      End If

      Select Case lngStatus
         Case 100 : Return_StatusDesc = "Continue"
         Case 101 : Return_StatusDesc = "Switching Protocols"
         Case 200 : Return_StatusDesc = "OK"
         Case 201 : Return_StatusDesc = "Created"
         Case 202 : Return_StatusDesc = "Accepted"
         Case 203 : Return_StatusDesc = "Non-Authoritative Information"
         Case 204 : Return_StatusDesc = "No Content"
         Case 205 : Return_StatusDesc = "Reset Content"
         Case 206 : Return_StatusDesc = "Partial Content"
         Case 300 : Return_StatusDesc = "Multiple Choices"
         Case 301 : Return_StatusDesc = "Moved Permanently"
         Case 302 : Return_StatusDesc = "Found"
         Case 303 : Return_StatusDesc = "See Other"
         Case 304 : Return_StatusDesc = "Not Modified"
         Case 305 : Return_StatusDesc = "Use Proxy"
         Case 307 : Return_StatusDesc = "Temporary Redirect"
         Case 400 : Return_StatusDesc = "Bad Request"
         Case 401 : Return_StatusDesc = "Unauthorized"
         Case 402 : Return_StatusDesc = "Payment Required"
         Case 403 : Return_StatusDesc = "Forbidden"
         Case 404 : Return_StatusDesc = "Not Found"
         Case 405 : Return_StatusDesc = "Method Not Allowed"
         Case 406 : Return_StatusDesc = "Not Acceptable"
         Case 407 : Return_StatusDesc = "Proxy Authentication Required"
         Case 408 : Return_StatusDesc = "Request Timeout"
         Case 409 : Return_StatusDesc = "Conflict"
         Case 410 : Return_StatusDesc = "Gone"
         Case 411 : Return_StatusDesc = "Length Required"
         Case 412 : Return_StatusDesc = "Precondition Failed"
         Case 413 : Return_StatusDesc = "Request Entity Too Large"
         Case 414 : Return_StatusDesc = "Request-URI Too Long"
         Case 415 : Return_StatusDesc = "Unsupported Media Type"
         Case 416 : Return_StatusDesc = "Requested Range Not Suitable"
         Case 417 : Return_StatusDesc = "Expectation Failed"
         Case 500 : Return_StatusDesc = "Internal Server Error"
         Case 501 : Return_StatusDesc = "Not Implemented"
         Case 502 : Return_StatusDesc = "Bad Gateway"
         Case 503 : Return_StatusDesc = "Service Unavailable"
         Case 504 : Return_StatusDesc = "Gateway Timeout"
         Case 505 : Return_StatusDesc = "HTTP Version Not Supported"
         Case Else : Return_StatusDesc = "(UNKNOWN SERVER STATUS RETURNED)"
      End Select

   End Function

#End Region

End Class