Subir archivos a dropbox por VBA

   Hola. Hace un tiempo que no ando por aqui, deje un poco access de lado...
Hace unos 3 años consegui subir archivos a dropbox por vba, con mucha ayuda, guarracuco se llamaba el que me ayudo.  El hilo ya no esta online, pero me lo guarde....

La cuestion es que los token de dropbox que creo ahora caducan a las 4 horas, y por mas que busco no encuentro solucion.

No me queda claro si es que hago algo mal a crear el token, en principio casi seguro que este paso es correcto.

O es que hay que modificar algo en el codigo por algo que dropbox a cambiado el la api.

Pongo el codigo que funcionaba y (funciona con un toquen que utilizo yo antiguo que no caduca ) pero que con los nuevos no va....solo las 4 primeras horas...

A ver si se os ocurre algo

Public Function SubirDropbox(varToken, varDirectorioDropbox, varArchivo As String)

On Error GoTo Err_SubirDropbox

Dim req As Object
Dim arg As String
Dim result As Variant    'Si ponemos option explicit hay que declararla como Variant

    result = FRB(varArchivo)  'Pasamos a binario

    arg = "{""path"":""" & varDirectorioDropbox & """,""mode"":""add"",""autorename"":false,""mute"":true}"
    'arg = "{""path"":""" & varfile & """,""mode"":""overwrite"",""autorename"":false,""mute"":true}"

    Set req = CreateObject("WINHTTP.WinHTTPRequest.5.1")
    'ResolveTimeout,ConnectTimeout,SendTimeout,ReceiveTimeout
    req.SetTimeouts 30000, 600000, 600000, 600000        'Tiempo en milisegundos para temas de tiempos de conexion y no se corte al subir un archivo

    req.Open "POST", "https://content.dropboxapi.com/2/files/upload", False
    req.setRequestHeader "Authorization", "Bearer " & varToken       'Hay que poner el token de la aplicacion de dropbox en la variable
    req.setRequestHeader "Content-Type", "application/octet-stream"

    req.setRequestHeader "Dropbox-API-Arg", arg
    req.setRequestHeader "User-Agent", "api-explorer-client"
    req.send (result)

If req.status = 200 Then

Debug.Print req.responseText
MsgBox req.responseText, , "OK, archivo subido correctamente a Dropbox"
Else
MsgBox req.status & ": " & req.statusText
Debug.Print req.responseText
MsgBox req.responseText
End If

Exit_SubirDropbox:
    Exit Function

Err_SubirDropbox:
    If Err.Number = 76 Then
    MsgBox Err.Description & " ,error 76.", vbExclamation, "La ruta del archivo a subir no es correcta."
    Else
    MsgBox Err.Description
    End If
    'MsgBox Err.Description
    Resume Exit_SubirDropbox

End Function

Public Function FRB(ByVal sRuta As String) As Byte()   'Pasamos directorio a binario
    Dim b() As Byte
    Open sRuta For Binary As #1
    ReDim b(FileLen(sRuta) - 1) '''''****ESTE -1 ES LA SOLUCIÓN PARA QUE NO CORROMPA LOS ARCHIVOS******RESTARLE UN BYTE
    Get #1, , b
    Close #1
    FRB = b
End Function

Autor	Mensaje Tema Buscar Opciones del Tema Responder Crear un nuevo tema Versión imprimible Traducir Tema
rokoko Ver perfil usuario Enviar mensaje privado Ver los mensajes del usuario Añadir a la lista de amigos Colaborador Unido: 16/Febrero/2008 Localización: Pamplona Estado: Sin conexión Puntos: 3062	Tema: Subir archivos a dropbox por VBA Enviado: 12/Diciembre/2022 a las 08:59
	Hola. Hace un tiempo que no ando por aqui, deje un poco access de lado... Hace unos 3 años consegui subir archivos a dropbox por vba, con mucha ayuda, guarracuco se llamaba el que me ayudo. El hilo ya no esta online, pero me lo guarde.... La cuestion es que los token de dropbox que creo ahora caducan a las 4 horas, y por mas que busco no encuentro solucion. No me queda claro si es que hago algo mal a crear el token, en principio casi seguro que este paso es correcto. O es que hay que modificar algo en el codigo por algo que dropbox a cambiado el la api. Pongo el codigo que funcionaba y (funciona con un toquen que utilizo yo antiguo que no caduca ) pero que con los nuevos no va....solo las 4 primeras horas... A ver si se os ocurre algo Public Function SubirDropbox(varToken, varDirectorioDropbox, varArchivo As String) On Error GoTo Err_SubirDropbox Dim req As Object Dim arg As String Dim result As Variant 'Si ponemos option explicit hay que declararla como Variant result = FRB(varArchivo) 'Pasamos a binario arg = "{""path"":""" & varDirectorioDropbox & """,""mode"":""add"",""autorename"":false,""mute"":true}" 'arg = "{""path"":""" & varfile & """,""mode"":""overwrite"",""autorename"":false,""mute"":true}" Set req = CreateObject("WINHTTP.WinHTTPRequest.5.1") 'ResolveTimeout,ConnectTimeout,SendTimeout,ReceiveTimeout req.SetTimeouts 30000, 600000, 600000, 600000 'Tiempo en milisegundos para temas de tiempos de conexion y no se corte al subir un archivo req.Open "POST", "https://content.dropboxapi.com/2/files/upload", False req.setRequestHeader "Authorization", "Bearer " & varToken 'Hay que poner el token de la aplicacion de dropbox en la variable req.setRequestHeader "Content-Type", "application/octet-stream" req.setRequestHeader "Dropbox-API-Arg", arg req.setRequestHeader "User-Agent", "api-explorer-client" req.send (result) If req.status = 200 Then Debug.Print req.responseText MsgBox req.responseText, , "OK, archivo subido correctamente a Dropbox" Else MsgBox req.status & ": " & req.statusText Debug.Print req.responseText MsgBox req.responseText End If Exit_SubirDropbox: Exit Function Err_SubirDropbox: If Err.Number = 76 Then MsgBox Err.Description & " ,error 76.", vbExclamation, "La ruta del archivo a subir no es correcta." Else MsgBox Err.Description End If 'MsgBox Err.Description Resume Exit_SubirDropbox End Function Public Function FRB(ByVal sRuta As String) As Byte() 'Pasamos directorio a binario Dim b() As Byte Open sRuta For Binary As #1 ReDim b(FileLen(sRuta) - 1) '''''**ESTE -1 ES LA SOLUCIÓN PARA QUE NO CORROMPA LOS ARCHIVOS**RESTARLE UN BYTE Get #1, , b Close #1 FRB = b End Function**

rokoko Ver perfil usuario Enviar mensaje privado Ver los mensajes del usuario Añadir a la lista de amigos Colaborador Unido: 16/Febrero/2008 Localización: Pamplona Estado: Sin conexión Puntos: 3062	Enviado: 30/Mayo/2023 a las 18:41
	Buenas!! Se puede cerrar. No consegui solucionarlo...