تحميل ملف من موقع dropbox على سطح المكتب

[علياء يسرالدين]

السلام عليكم... هل يوجد دالة او كود لجلب ملف من موقع dropbox على سطح المكتب .. وشكرا لكم

[ahmedsbra]

Function DownloadDBFile(myURL As String, saveToPath As String)
Dim WinHttpReq As Object
Dim iTimer As Long
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "xxxxxxxxxxxx@gmail.com", "xxxxxxxxxxxxxxxx"
Debug.Print WinHttpReq.ReadyState
WinHttpReq.Send
'make sure readystate is finished
iTimer = Timer
Do While WinHttpReq.ReadyState = 1
'if 10 seconds elapse and nothing happens, abort:
If Timer - iTimer > 10 Then Exit Do
Loop
'readystate 4 = all data received
If WinHttpReq.ReadyState = 4 Then
    If WinHttpReq.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write WinHttpReq.responseBody
    oStream.SaveToFile saveToPath, 2 ' 1 = no overwrite, 2 = overwrite
    oStream.CLOSE
Me.waitfordownload.Visible = False
    Else
    MsgBox ("HTTP error: " & WinHttpReq.Status)
   End If
Else
MsgBox ("Couldn't get file")
End If
Set oStream = Nothing
Set WinHttpReq = Nothing
End Function

وفي زر الامر ضع الاتي 

If IsNull(savetox) Then
MsgBox "يرجى اختيار مكان حفظ التحديثات "
Else
Me.waitfordownload.Visible = True
Me.Requery

Me.TabDown.Value = 1
Dim PathDBFile  As String
Dim PathUpdateFolder As String

PathUpdateFolder = CurrentProject.path & "\" & "LinkToUpdate"
If Len(Dir(PathUpdateFolder, vbDirectory)) = 0 Then
MkDir path:=PathUpdateFolder
End If
DownloadDBFile UrlDB, Me.savetox
End If

 

تم تعديل نوفمبر 9, 2021 بواسطه jjafferr
إظهار الكود بالطريقة الصحيحة بإستعمال زر <> من القائمة

[علياء يسرالدين]

جزاك الله خيرا ... ونفع الله بك