هل هناك دالة تحول الرابط الى صورة ؟ كود للتحميل المباشر من جوجل درايف Google drive

[عالم الهندسة]

اقوم بتصميم نموذج عبر قوقل ومن ضمن البيانات ارفاق صورة هل هناك دالة تحول الرابط الى صورة في الاكسس وارفاقه في الفورم

ارفاق صورة.accdb

[Moosak]

12 ساعات مضت, عالم الهندسة said:

هل هناك دالة تحول الرابط الى صورة في الاكسس

الرابط الموجود في الفورم لم يتم إعداده للمشاركة ( يطلب إذن لتحميله ) ، يجب عليك إتاحة المشاركة للتمكن من التحميل ..
 

هذا هو كود التحميل من الجوجل درايف :

كود للتحميل المباشر من الجوجل درايف Google drive

شرح الكود:
لتحميل الملفات من جوجل درايف بنفس الاسم والامتداد
فقط تحتاج رابط الملف كاملا وأن يكون الملف عاما (مشاركا مع الجميع)
الكود يعالج مشكلة أسماء الملفات العربية
صالح للنواتين 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 oStream = Nothing
MsgBox "تم تحميل الملف في نفس مسار البرنامج باسم: " & vbNewLine & vbNewLine & 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