طريقة الجلب من قوقل درايف بالكود

[أبو امين]

تحدثنا كثيرا عن  تصدير قاعدة البيانات الى قوقل درايف و تعددت الاكواد منها من عمل  و منها كان مقتضبا و قشل : 

فهل نستطيع انشاء كود لجلب نسخة قاعدة البيانات من قوقل درايف ؟

همتكم يا اساتذتي الكرام 

هل تعجزون عن ايجاد حل لذلك 

[kanory]

في 30‏/5‏/2022 at 17:06, د.كاف يار said:

اخي الكريم 

لتسهيل عملية التحديث اقترح عليك ان تستعين بــ Google drive

بحيث تقوم برفع آخر نسخة من التعديلات الى  Google drive

و من خلال الكود سيتم تحميل هذه النسخة الى جهاز العميل او المستخدم الآخر

و حتى يتم ذلك يجب ان تقوم بإنشاء Module جديد و الصق فيه الكود التالي

Option Compare Database
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
        Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, _
        ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
#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

Function downloadFile( _
    ByVal FileURL As String, _
    ByVal FilePath As String) _
As Boolean
    Const ProcName As String = "downloadFile"
    On Error GoTo clearError
    
    URLDownloadToFile 0, FileURL, FilePath, 0, 0
    downloadFile = True

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

Sub downloadGoogleDrive(FilePath As String, FileID As String)
    
    Const UrlLeft As String = "http://drive.google.com/u/0/uc?id="
    Const UrlRight As String = "&export=download"
        
    Dim Url As String: Url = UrlLeft & FileID & UrlRight
    
    Dim wasDownloaded As Boolean
    wasDownloaded = downloadFile(Url, FilePath)
    If wasDownloaded Then
        MsgBox "Success"
    Else
        MsgBox "Fail"
    End If

End Sub

Sub NewFileText()
On Error Resume Next
Dim FileSeveTo As String
FileSeveTo = CurrentProject.Path & "\" & Right$(CurrentProject.FullName, _
                                                Len(CurrentProject.FullName) _
                                                - InStrRev(CurrentProject.FullName, "\"))
Dim GoogleFileID As String: GoogleFileID = "1DQqZYciRIs_dcBE6JLeoqiB3zjcq2SpL"
Call downloadGoogleDrive(FileSeveTo, GoogleFileID)

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fso.CreateTextFile(CurrentProject.Path & "\UpdateFile.cmd")
    oFile.WriteLine "@Echo OFF"
    oFile.WriteLine "SLEEP 3"
    oFile.WriteLine "copy " & """" & FileSeveTo & """" & " " & """" & CurrentProject.FullName & """" & " /Y"
    oFile.WriteLine "call " & """" & CurrentProject.FullName & """"
    oFile.WriteLine "exit"
    oFile.Close
Set fso = Nothing
Set oFile = Nothing
'تشغيل ملف النظام
Dim RetVal
    RetVal = Shell(CurrentProject.Path & "\UpdateFile.cmd", 1)
Application.CloseCurrentDatabase
End Sub

 

 

و للاستدعاء لتحميل الملف و استبدال النسخة الحالية للمستخدم 

استخدم الكود التالي في ازرار التحديث او في اي اجراء تستخدمه للتحديث (( لا تنسى وضع مفتاح الملف الذي حصلت عليه من قوقل ))

'===========================================================================
Dim GoogleFileID As String: GoogleFileID = "مفتاح الملف من قوقل درايف"
'===========================================================================
Dim FileSeveTo As String
FileSeveTo = CurrentProject.Path & "\" & Right$(CurrentProject.FullName, _
                                                Len(CurrentProject.FullName) _
                                                - InStrRev(CurrentProject.FullName, "\"))

Call downloadGoogleDrive(FileSeveTo, GoogleFileID)

 

 

 

 

 

[أبو امين]

مشكور استاذي الكريم بارك الله فيك و جعله في صالح اعمالك 

ساجرب الكود و اوافيك بالنتسجة ان شاء الله 

 

و الله استاذي الكريم حاولت لكن عجزت

[د.كاف يار]

ارفق نسخة لكي يتم التعديل عليها

[أبو امين]

المثال استاذي الكريم

استاذي ماذا نقصد بما كتبته : 

im GoogleFileID As String: GoogleFileID = "مفتاح الملف من قوقل درايف"

 

هل ان مفتاح الملف يعني الايمايل ام كلمة السر ام الرابط 

مع العلم انني نزلت google driver  على الحاسوب و كل مرة اشغل فيها المثال من المقروض ان اجد القاعدة اضيفت بقوقل درايف لكن لا يوجد شيء

مثال.accdb

تم تعديل يونيو 3, 2022 بواسطه derbali ammar

[د.كاف يار]

تفضل التعديل

فقط قم بإضافة رابط الملف داخل مربع النص

 

 

مثال.accdb

[abouelhassan]

شكر وتقدير وفائق الاحترام استاذى الحبيب لقلبى

[ابو البشر]

اخي الدكتور @د.كاف يار واضح ان البرنامج يغير من تنسيق الملف ويظهر عند فتحه أن التنسيق غير معروف   ..... لكن ::

هل ممكن ان يتم تحميل الملف بنفس تنسيقة واسمه في القوقل درايف دون تعديل ....؟؟؟؟ جزاك الله خيرا 

[أبو امين]

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

[أ / محمد صالح]

بعد إذن جميع الأصدقاء المشاركين في هذا الموضوع الرائع

هذا جهدي المتواضع لتحميل الملفات من جوجل درايف بنفس الاسم والامتداد

فقط تحتاج رابط الملف كاملا وأن يكون الملف عاما (مشاركا مع الجميع)

الكود يعالج مشكلة أسماء الملفات العربية

صالح للنواتين 32بت وكذلك 64بت

يعمل في كل التطبيقات التي تستعمل vba

يوضع هذا الكود في موديول جديد

Sub DownloadFromGD(GDriveURL As String)
Dim myURL As String
Dim FileID As String
Dim xmlhttp As Object
Dim name0 As Variant
Dim oStream As Object
FileID = Split(Split(GDriveURL, "/d/")(1), "/")(0)
myURL = "http://drive.google.com/u/0/uc?id=" & FileID & "&export=download"
Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP")
xmlhttp.Open "GET", myURL, False 
xmlhttp.Send
name0 = DECODEURL(xmlhttp.getResponseHeader("Content-Disposition"))
If name0 = "" Then
    MsgBox "الملف غير موجود في الموقع"
    Exit Sub
End If
name0 = Split(name0, "*=UTF-8''")(1) 'split after *=UTF-8'' to get utf8 names
If xmlhttp.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write xmlhttp.responseBody
    oStream.SaveToFile CurrentProject.Path & "\" & name0, 2 ' 1 = no overwrite, 2 = overwrite
    oStream.Close
End If
Set xmlhttp = Nothing
Set Stream = Nothing
MsgBox "تم تحميل الملف في نفس مسار البرنامج باسم: " & name0
End Sub
Function DECODEURL(varText As Variant)
Static objHtmlfile As Object
If objHtmlfile Is Nothing Then
    Set objHtmlfile = CreateObject("htmlfile")
    objHtmlfile.parentWindow.execScript "function decode(s) {return decodeURIComponent(s)}", "jscript"
End If
DECODEURL = objHtmlfile.parentWindow.decode(varText)
End Function

طريقة استخدام الكود مثل السطر المكتوب في الإجراء test أو يمكن وضعه عند الضغط على زر مثلا

ويتكون هذا السطر من كتابة اسم الاجراء DpwnloadFromGD ثم رابط الملف المراد تحميله بين علامتي تنصيص ويمكن استخدام قيمة مربع النص بدلا من تثبيت رابط الموقع

Sub test()
DownloadFromGD "https://drive.google.com/file/d/18jrvTxgR1QTzwm8YaJHIvsdOmqj02L2x/view"
End Sub

ولا تنسوني من صالح دعائكم

بالتوفيق للجميع

[أبو امين]

استاذي قمت بالمطلوب لكن تظهر هذه الرسالة 

مع العلم انني استبدلت الرابط لكن ما مشي الحال 

لقد ارفقت لك المثال و به رابط ملفي الرجاء العمل عليه لو سمحت 

1215.rar

تم تعديل يونيو 4, 2022 بواسطه derbali ammar

[أ / محمد صالح]

قبل التحميل ومراجعة ملفك 

هل رابط الملف في جوجل درايف تمت مشاركته مع كل من يعرف الرابط أم انه خاص بمالكه فقط؟؟ 

ربما يكون هذا سبب الخطأ 

اقتباس

وأن يكون الملف عاما

 

[أبو امين]

الله الله عليك استاذي : ما شاء الله لقد نجحت العملية و بامتياز شكرا شكرا شكرا شكرا لك و جعلها الله في ميزان حسناتك 

تمت العملية بنجاح المشكلة فعلا كانت في قوقل درايف حيث مكنت خاصية المشاركة و نجحت العملية بارك الله فيك و جعلك ذخرا لكل مبتدء و جعل الله  مساعداتك و نصائحك في مزان حسناتك

تم تعديل يونيو 4, 2022 بواسطه derbali ammar

[أ / محمد صالح]

جميعا بإذن الله