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