هل توجد طريقة لترحيل الصور من قاعدة البيانات الى خارجها وحفظها بفولدر ؟

[مهند جاسم الشمري]

السلام عليكم مساعدة ( عندي قاعدة بيانات فيها صورة محزونة على شكل ( OLE) ولم احتفظ بالصور خارج القاعدة هل توجد طريقة لترحيل الصور من قاعدة البيانات الى خارجها وحفظها بفولدر وجزاكم الله 

[Moosak]

وعليكم السلام 🙂 

هذا كود لحفظ أو استخراج المرفقات من حقل نوع مرفق إلى جهاز الكمبيوتر ..

الدالة الأولى هي دالة استخراج المرفقات ..
الدالة الثانية هي دالة الحصول على مسارات المجلدات الخاصة ( سطح المكتب مثلا ..)

Public Sub AttachmentToDisk(strTableName As String, _
       strAttachmentField As String, strPrimaryKeyFieldName As String)
    Dim strFileName As String
    Dim db     As DAO.Database
    Dim rsParent As DAO.Recordset2
    Dim rsChild As DAO.Recordset2
    Dim fld    As DAO.Field2
    Dim strPath As String
     On Error Resume Next
    strPath = SpecialFolderPath("MyDocuments") & "\" & Form_Main.TB1.Value & "\"   ' مكان حفظ المرفقات
  '  strPath = " Application.CurrentProject.Path" & " \ " & Form_Main.TB1.Value & "\"
    Set db = CurrentDb
    Set rsParent = db.OpenRecordset(strTableName, dbOpenSnapshot)
    With rsParent
        If .RecordCount > 0 Then .MoveFirst
        While Not .EOF
            ' our picture is in the field "pics"
            Set rsChild = rsParent(strAttachmentField).Value
            If rsChild.RecordCount > 0 Then rsChild.MoveFirst
            While Not rsChild.EOF
                ' this is the actual image content
                Set fld = rsChild("FileData")
                ' create full path and filename
                strFileName = strPath & .Fields(strPrimaryKeyFieldName) & "\" & rsChild("FileName")
                ' create directory if it does not exists
                If Len(Dir(strPath & .Fields(strPrimaryKeyFieldName), vbDirectory)) = 0 Then VBA.MkDir strPath & .Fields(strPrimaryKeyFieldName)
                ' remove any previous picture from disk it there is any
                If Len(Dir(strFileName)) <> 0 Then Kill strFileName
                ' save our picture to disk
                fld.SaveToFile strFileName
                ' move to next attachment
                rsChild.MoveNext
            Wend
            ' move record pointer of parent
            .MoveNext
        Wend
    End With
    Set fld = Nothing
    Set rsChild = Nothing
    Set rsParent = Nothing
    Set db = Nothing
    
End Sub
Public Function SpecialFolderPath(strFolder As String) As String
    ' Find out the path to the passed special folder. User on of the following arguments:
    ' Options For specical folders
    '        AllUsersDesktop
    '        AllUsersStartMenu
    '        AllUsersPrograms
    '        AllUsersStartup
    '        Desktop
    '        Favorites
    '        Fonts
    '        MyDocuments
    '        NetHood
    '        PrintHood
    '        Programs
    '        Recent
    '        SendTo
    '        StartMenu
    '        Startup
    '        Templates
    On Error GoTo ErrorHandler
    'Create a Windows Script Host Object
    Dim objWSHShell As Object
    Set objWSHShell = CreateObject("WScript.Shell")
    'Retrieve path
    SpecialFolderPath = objWSHShell.SpecialFolders(strFolder & "")
CleanUp:
    ' Clean up
    Set objWSHShell = Nothing
    Exit Function
    '**************************************
    '*      Error Handler
    '**************************************
ErrorHandler:
    MsgBox "Error finding " & strFolder, vbCritical + vbOKOnly, "Error"
    Resume CleanUp
End Function

 

[مهند جاسم الشمري]

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

opppol.accdb

[Moosak]

تفضل أخي مهند 🙂 

opppol.accdb

[hanafymahmood]

السلام عليكم ورحمة الله وبركاته

مهتم جداً بهذا الموضوع وحاولت تنفيذه إلا إننى لم أوفق دائماً تأتى رسالة runtime error 3601 ولى طلب لا أعلم إن كانت قوانين المنتدى تسمح به من عدمه وهو أن يتفضل الأخ الكريم جزاه الله خيراً بالدخول معى أونلاين فى الوقت الذى يناسبه لمساعدتى فى محاولة التنفيذ .... عذراً قاعدة البيانات كبيرة فيها ما يقرب من 8000 صورة 

وجزاكم الله خيرا

[Moosak]

3 ساعات مضت, hanafymahmood said:

السلام عليكم ورحمة الله وبركاته

مهتم جداً بهذا الموضوع وحاولت تنفيذه إلا إننى لم أوفق دائماً تأتى رسالة runtime error 3601 ولى طلب لا أعلم إن كانت قوانين المنتدى تسمح به من عدمه وهو أن يتفضل الأخ الكريم جزاه الله خيراً بالدخول معى أونلاين فى الوقت الذى يناسبه لمساعدتى فى محاولة التنفيذ .... عذراً قاعدة البيانات كبيرة فيها ما يقرب من 8000 صورة 

وجزاكم الله خيرا

وعليكم السلام ورحمة الله وبركاته أخي @hanafymahmood 🙂 

خذ نسخة من البرنامج (مهم) .. واحذف منها جميع السجلات ما عدا 10 تقريبا تضعها كنموذج للتجربة عليها ..

وأرفق البرنامج في موضوع جديد مستقل ( مهم ) .. ثم أشر لهذا الموضوع بوضع الرابط الخاص به في موضوعك الجديد ..

ونتمنى لك التوفيق 🙂