Exemplo Download Direto / Download Direto Dropbox

Olá,
A propósito de questão de colega, partilho exemplo adapatdo para Download Direto.
Código utilizado:

Código:

Option Compare Database
' Autor ..: Alvaro Teixeira (ahteixeira)
' Para ...: MaximoAccess.com
' Data ...: 16-02-2017
' Função .: Download Directo
' Adaptado: http://www.maximoaccess.com/t28700-baixar-arquivos-de-sites-como-googledrive-mega-ou-outro

#If VBA7 Then
    Private Declare PtrSafe 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
#Else
    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
#End If
  

Private Sub cmdDownload_Click()
    On Error GoTo Err
    Dim Auxiliar As Long
    Dim URL, CaminhoLocal, sFicheiro As String
    
    URL = Me.txtURL
    sFicheiro = Right(URL, Len(URL) - InStrRev(URL, "/"))
    CaminhoLocal = Me.txtCaminho & sFicheiro
    
    Auxiliar = URLDownloadToFile(0, URL, CaminhoLocal, 0, 0)
    
    If Auxiliar = 0 Then
       MsgBox "Download efetuado com sucesso!", vbInformation
    Else
       MsgBox "Erro no download do arquivo.", vbCritical, ""
    End If
    Exit Sub

Err:
   MsgBox Err.Number & "-" & Err.Description, vbCritical, "Erro no download do arquivo."
End Sub


Abraço

Muito bom Obrigado

Olá a todos,
Eliminei o exemplo da mensagem nº 1.
Agora tem mais um exemplo que permite fazer o download direto de link do Dropbox.

Código utilizado:

Código:

Option Compare Database
' Autor ..: Alvaro Teixeira (ahteixeira)
' Para ...: MaximoAccess.com
' Data ...: 10-03-2017
' Função .: Download Directo
' Adaptado: http://analystcave.tumblr.com/post/136973006098/how-to-download-files-using-vba-in-excel

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 Sub cmdDownload_Click()
    Dim sURL, CaminhoLocal, sFicheiro As String
        
    If IsNull(Me.txtURL) Then Exit Sub
    
    sURL = Me.txtURL
    sURL = Replace(sURL, "?dl=0", "?dl=1") '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 = Me.txtCaminho & 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
    Me.txtEstado = "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
      Me.txtEstado = "A fazer Download do ficheiro. " & CLng(totalRead / 1024) & " KB recebidos."
      DoEvents
    Loop

    Me.txtEstado = "Download completo."
    ostream.SaveToFile CaminhoLocal, 2
    ostream.Close
  End If
  Call InternetCloseHandle(hInternet)
End Sub


O ficheiro anexo tem este exemplo e o da mensagem nº 1.

Olá boa noite,

Testei e tenho a dizer que está excelente (,")
Muito obrigado pela partilha mestre AhTeixeira.

Abraço

Bom dia, ahteixeira.

Exemplo perfeito, só perguntaria se tem como alterá-lo para ser mais rápido... achei um pouco lento.

Obrigado.

leoni_dias,

A velocidade de download não depende do código escrito pelo amigo "ahteixeira" e sim da velocidade de conexão com a internet, bem como do tamanho do arquivo.

Boa tarde.

Eu acredito não ser bem assim, Uilson.

Eu fiz um mesmo download de 1,8 mega, usando o código, o google e automatcamente pelo próprio dropbox instalado no pc e usando a mesma internet.

Pelo google e pelo dropbox do pc foram bem mais rápido do que pelo código, e olha que não testei em arquivos que uso que são de 25 megas +-.

Testei na prática pra poder fazer a pergunta sobre a rapidez.

Olá a todos,

No link abaixo para quem pretender com https, contribuíção do colega Franklin Crivelaro:
https://www.maximoaccess.com/t41872-solucao-da-falha-no-protocolo-https-de-exemplo

Bons estudos