' DownloadBinary
' http://www.utteraccess.com/wiki/index.php/DownloadBinary
' Code courtesy of UtterAccess Wiki
' Licensed under Creative Commons License
' http://creativecommons.org/licenses/by-sa/3.0/
'
' You are free to use this code in any application,
' provided this notice is left unchanged.
'
' rev  date                          brief descripton
' 1.0  2012-01-17                    
'
Public Function DownloadBinary( _
   src As String, _
   dest As String, _
   Optional TimeoutMS As Long = 45000, _
   Optional ByRef Header As String _
   ) As Long
 'Currently provides no validation for src or dest
 'prelim version
 'returns 0 on success
 'returns -1 on timeout
 'returns httpRequestStatus on other errors
 
 Const HTTPREQ_TIMEOUT_CHECK = 50
 
 Dim req As Object
 Dim lTimer As Long
 Dim bFlag As Boolean
 Dim bTimeout As Boolean
 
 Dim vBytes As Variant
 Dim bBytes() As Byte
 
 Dim iFile As Integer
 
 Set req = CreateObject("MSXML2.XMLHTTP.3.0")
 req.Open "GET", src, True
 req.Send
 
 'timeout
 While bFlag = False
   DoEvents: DoEvents: DoEvents
   If req.readystate <> 4 Then
     'not done
     If lTimer >= TimeoutMS Then
       bFlag = True
       bTimeout = True
     End If
   Else
     bFlag = True
   End If
   Sleep HTTPREQ_TIMEOUT_CHECK
   lTimer = lTimer + HTTPREQ_TIMEOUT_CHECK
 Wend

 If bTimeout Then
   DownloadBinary = -1 'timeout
 Else
   If req.Status = 200 Then
     
     Header = req.getAllResponseHeaders()
   
     vBytes = req.responseBody

     ReDim bBytes(0 To UBound(vBytes))
     bBytes = vBytes
     
     iFile = FreeFile()
     Open dest For Binary Access Write As #iFile
     Put #iFile, , bBytes
     Close #iFile
     
     DownloadBinary = 0
     
   Else
     DownloadBinary = req.Status
   End If
 End If
 
 Set req = Nothing
 
End Function