MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

+2
danilo451
Alvaro Teixeira
6 participantes

    Exemplo Download Direto / Download Direto Dropbox

    Alvaro Teixeira
    Alvaro Teixeira
    Moderador Global
    Moderador Global


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 7715
    Registrado : 15/03/2013

    Exemplo Download Direto / Download Direto Dropbox Empty Exemplo Download Direto / Download Direto Dropbox

    Mensagem  Alvaro Teixeira 16/2/2017, 16:04

    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


    Última edição por ahteixeira em 10/3/2017, 20:10, editado 2 vez(es)
    avatar
    danilo451
    Novato
    Novato


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 24
    Registrado : 19/04/2016

    Exemplo Download Direto / Download Direto Dropbox Empty Re: Exemplo Download Direto / Download Direto Dropbox

    Mensagem  danilo451 9/3/2017, 15:21

    Muito bom Obrigado
    Alvaro Teixeira
    Alvaro Teixeira
    Moderador Global
    Moderador Global


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 7715
    Registrado : 15/03/2013

    Exemplo Download Direto / Download Direto Dropbox Empty Re: Exemplo Download Direto / Download Direto Dropbox

    Mensagem  Alvaro Teixeira 10/3/2017, 20:19

    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.

    cheers
    Anexos
    Exemplo Download Direto / Download Direto Dropbox Attachmentdownload_Direto_Dropbox.zip
    Você não tem permissão para fazer download dos arquivos anexados.
    (26 Kb) Baixado 267 vez(es)
    pcnet
    pcnet
    Avançado
    Avançado


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 303
    Registrado : 16/12/2015

    Exemplo Download Direto / Download Direto Dropbox Empty Re: Exemplo Download Direto / Download Direto Dropbox

    Mensagem  pcnet 10/3/2017, 21:23

    Olá boa noite,

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

    Abraço
    leoni_dias
    leoni_dias
    Intermediário
    Intermediário


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 179
    Registrado : 14/08/2011

    Exemplo Download Direto / Download Direto Dropbox Empty Re: Exemplo Download Direto / Download Direto Dropbox

    Mensagem  leoni_dias 21/9/2018, 13:07

    Bom dia, ahteixeira.

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

    Obrigado.
    Uilson Brasil
    Uilson Brasil
    VIP
    VIP


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 1037
    Registrado : 23/04/2013

    Exemplo Download Direto / Download Direto Dropbox Empty Re: Exemplo Download Direto / Download Direto Dropbox

    Mensagem  Uilson Brasil 21/9/2018, 17:02

    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.


    .................................................................................
    ::: Uilson Brasil
    ::: Design in Microsoft Access
    leoni_dias
    leoni_dias
    Intermediário
    Intermediário


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 179
    Registrado : 14/08/2011

    Exemplo Download Direto / Download Direto Dropbox Empty Re: Exemplo Download Direto / Download Direto Dropbox

    Mensagem  leoni_dias 21/9/2018, 18:47

    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.
    avatar
    franklin.crivelaro
    Novato
    Novato


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 2
    Registrado : 05/01/2016

    Exemplo Download Direto / Download Direto Dropbox Empty Solução da falha no protocolo HTTPS

    Mensagem  franklin.crivelaro 10/1/2023, 03:14

    Caros Companheiros do Forum,
    Eu me deparei com uma falha ao tentar usar a api URLDownloadToFile que não gerava erro quando o download do arquivo é oriundo de uma url que utiliza o protocolo HTTPS.
    Com protocolo HTTP funciona corretamente.

    A solução identifiquei no link abaixo, abandonando o uso da api URLDownloadToFile e quero compartilhar com vocês:

    stackoverflow.com/questions/34923409/excel-vba-urldownloadtofile-error-for-httpsresource

    No código de exemplo abaixo, na chamada da sub é passado a url e caminho de destino (com nome do arquivo  e extensão)

    Private Sub BaixaArquivo()

       call download_arquivo("https:\\suaurl","C:seudiretorio\seuarquivo.txt")
     
    end sub

    Public Sub download_arquivo(strurl As String, strpath_destino As String)
       Dim oStream As Object
       Dim WinHttpReq As Object
       Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
       WinHttpReq.Option(4) = 13056 ' Ignora Erros devido a certificado SSL
       
       On Error GoTo fim
       
       WinHttpReq.Open "GET", strurl, False
       
       WinHttpReq.setRequestHeader "Accept", "*/*"
       WinHttpReq.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
       WinHttpReq.setRequestHeader "Proxy-Connection", "Keep-Alive"
       WinHttpReq.Send
       
       'pega o retorno da chamada e passa para a var
       strurl = WinHttpReq.responseBody
       
       'se o status do retorno for 200, existe a url, cria um objeto de stream e passa o retorno para ele
       If WinHttpReq.status = 200 Then
           Set oStream = CreateObject("ADODB.Stream")
           oStream.Open
           oStream.Type = 1
           oStream.Write WinHttpReq.responseBody
           'salva o arquivo baixado no destino passado no parâmetro
           oStream.SaveToFile strpath_destino, 2
           'fecha o objeto
           oStream.Close
       Else
           'se o status não for de ok, apresenta msg ao usuário com o erro
           MsgBox "Código do Retorno:" & WinHttpReq.status & vbCr & "O Download não foi autorizado", vbExclamation, "Falha no download"
       End If
       
       Exit Sub
    fim:
       MsgBox Err.Description, vbExclamation, "Erro"
    End Sub

      Data/hora atual: 8/2/2023, 00:55