FALHA EM DOWNLOAD COM PROTOCOLO HTTPS EM VB6

 Tópico anterior Próximo tópico Novo tópico

FALHA EM DOWNLOAD COM PROTOCOLO HTTPS EM VB6

VB / VBA

 Compartilhe  Compartilhe  Compartilhe
#482823 - 07/07/2018 01:38:34

KELLY
BRASILIA
Cadast. em:Setembro/2009


Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function InternetOpen Lib "wininet" 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 InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer

Private Sub Form_Load()
If InternetGetFile("http://hdwpro.com/wp-content/uploads/2015/12/Birds-Image.jpg", "F:\imagem_http.jpg") = True Then
    MsgBox "Arquivo http baixado!"
End If
If InternetGetFile("https://www.planwallpaper.com/static/cache/76/ae/76aef16c40b4e4447233badc50b1845a.jpg", "F:\imagem_https.jpg") = True Then
    MsgBox "Arquivo https baixado!"
End If
End
End Sub

Function InternetGetFile(sURLFileName As String, sSaveToFile As String, Optional bOverwriteExisting As Boolean = False) As Boolean
    Dim lRet As Long
    Const S_OK As Long = 0, E_OUTOFMEMORY = &H8007000E
    Const INTERNET_OPEN_TYPE_PRECONFIG = 0, INTERNET_FLAG_EXISTING_CONNECT = &H20000000
    Const INTERNET_OPEN_TYPE_DIRECT = 1, INTERNET_OPEN_TYPE_PROXY = 3
    Const INTERNET_FLAG_RELOAD = &H80000000
    
    On Error Resume Next
    'Create an internet connection
    lRet = InternetOpen("", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
    
    If bOverwriteExisting Then
        If Len(Dir$(sSaveToFile)) Then
            VBA.Kill sSaveToFile
        End If
    End If
    'Check file doesn't already exist
    If Len(Dir$(sSaveToFile)) = 0 Then
        'Download file
        lRet = URLDownloadToFile(0&, sURLFileName, sSaveToFile, 0&, 0)
        If Len(Dir$(sSaveToFile)) Then
            'File successfully downloaded
            InternetGetFile = True
        Else
            'Failed to download file
            If lRet = E_OUTOFMEMORY Then
                Debug.Print "O tamanho do buffer é inválido ou não havia memória suficiente para concluir a operação."
            Else
                Debug.Assert False
                Debug.Print "Ocorreu um erro " & lRet & " (este é provavelmente um erro do servidor proxy)."
            End If
            InternetGetFile = False
        End If
    End If
    On Error GoTo 0
    
End Function





#482835 - 08/07/2018 16:49:26

GERMANO
TERESINA
Cadast. em:Maio/2005


Veja esse código

  Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Private Declare Function InternetReadBinaryFile Lib "wininet.dll" Alias "InternetReadFile" (ByVal hfile As Long, ByRef bytearray_firstelement As Byte, ByVal lNumBytesToRead As Long, ByRef lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long


Private Sub Form_Load()
    DownloadFile "https://www.planwallpaper.com/static/cache/76/ae/76aef16c40b4e4447233badc50b1845a.jpg", "s:\imagem_https_2.jpg"
    End
End Sub


Sub DownloadFile(sUrl As String, filePath As String, Optional overWriteFile As Boolean)
  Dim hInternet, hSession, lngDataReturned As Long, sBuffer() As Byte, totalRead As Long
  Dim iReadFileResult
  Dim oStream  As Object
  Const bufSize = 128
  ReDim sBuffer(bufSize)
  hSession = InternetOpen("", 0, vbNullString, vbNullString, 0)
  If hSession Then hInternet = InternetOpenUrl(hSession, sUrl, vbNullString, 0, INTERNET_FLAG_NO_CACHE_WRITE, 0)
  Set oStream = CreateObject("ADODB.Stream")
  oStream.Open
  oStream.Type = 1

  If hInternet Then
    iReadFileResult = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned)
    ReDim Preserve sBuffer(lngDataReturned - 1)
    oStream.Write sBuffer
    ReDim sBuffer(bufSize)
    totalRead = totalRead + lngDataReturned
    'Application.StatusBar = "Downloading file. " & CLng(totalRead / 1024) & " KB downloaded"
    DoEvents

    Do While lngDataReturned <> 0
      iReadFileResult = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned)
      If lngDataReturned = 0 Then Exit Do

      ReDim Preserve sBuffer(lngDataReturned - 1)
      oStream.Write sBuffer
      ReDim sBuffer(bufSize)
      totalRead = totalRead + lngDataReturned
      'Application.StatusBar = "Downloading file. " & CLng(totalRead / 1024) & " KB downloaded"
      DoEvents
    Loop

    'Application.StatusBar = "Download complete"
    oStream.SaveToFile filePath, IIf(overWriteFile, 2, 1)
    oStream.Close
  End If
  Call InternetCloseHandle(hInternet)
End Sub




#482860 - 09/07/2018 20:53:34

EPISCOPAL
VARZEA GRANDE
Cadast. em:Maio/2009


Sempre use apis do windows. A microsoft sempre atualiza as suas apis a cada versionamento ou lançamento.

____________________________________________________________________
Episcopal Studios




 Tópico anterior Próximo tópico Novo tópico


Para responder este tópico o login é requerido
Se você já possui uma conta de usuário por favor faça seu login
Se você não possui uma conta de usuário use a opção Criar usuário