Excel Download de arquivo (Dropbox) vba excel

Masterresende · 12 de março de 2022

Fala galera,

Gostaria de uma ajuda de vocês

Estou utilizando um código no VBA do Excel que até chegou a funcionar, baixando o arquivo normal (. Exe) 3.2mb

Mas não sei o que rolou que o arquivo baixando exibe 2k tipo não baixou corretamente e exibe a msg que está corrompido, detalhe desativei antivirus porque achei que poderia ser ele mas nada! E chegou a funcionar como disse...

Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000

Private Declare PtrSafe 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 PtrSafe 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 PtrSafe 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 PtrSafe Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer





Private Sub cmdDownload_Click()

    Dim sURL, CaminhoLocal, sFicheiro As String

       

    If IsNull(myURL) Then Exit Sub

   

    sURL = myURL

    sURL = ("https://www.dropbox.com/s/o8qql9kinec1eqc/exemplooooo") 'alterar url para download direto

   

    If Right(sURL, 5) <> "?dl=1" Then

        MsgBox "Não é um link preparado para download direto do Dropbox.", vbCritical, "Operação cancelada"

        Exit Sub

    End If

   

    sFicheiro = Right(sURL, Len(sURL) - InStrRev(sURL, "/"))

    sFicheiro = Left(sFicheiro, Len(sFicheiro) - 5)

    CaminhoLocal = myURLCaminho & sFicheiro



  Dim hInternet, hSession, lngDataReturned As Long, sBuffer() As Byte, totalRead As Long

  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

    myURLEstado = "A fazer Download do ficheiro. " & CLng(totalRead / 1024) & " KB recebidos."

    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

      myURLEstado = "A fazer Download do ficheiro. " & CLng(totalRead / 1024) & " KB recebidos."

      DoEvents

    Loop



    myURLEstado = "Download completo."

    ostream.SaveToFile CaminhoLocal, 2

    ostream.Close

  End If

  Call InternetCloseHandle(hInternet)

End Sub