اريد حفظ صور القاعدة بعد فرزهم في ملف خارجي

[hamdy1111]

السلام عليكم الاخوة الاعزاء

عندي ملف صور لكل الطلاب ناجحين وراسبين

وأنشئت جدول فيه بيانات كل الطلاب ووضعت صورة لكل طالب من ملف الصور

وفي النهاية عملت استعلام لعرض الطلاب الناجين فقط

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

برنامج لحفظ صور القاعدة داخل مجلد.rar

[محمد أبوعبدالله]

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

تفضل اخي الكريم

سيتم حفظ الصورة بمجلد الصور برقم جلوس كل طالب

برنامج لحفظ صور القاعدة داخل مجلد.rar

تحياتي

[hamdy1111]

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

[jjafferr]

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

 

هذا الكود سيحفظ لك جميع الصور الموجودة ، بغض النظر عن عدد الصور في الحقل ،

احفظ هذه الوحدة النمطية كما هي :

Public Function Export_Attached_Pictures(TQ_Name As String, fld_Name As String, Export_Folder_Name As String)
On Error GoTo err_Export_Attached_Pictures

    ' TQ_Name = Table or Query Name
    ' fld_Name = Attachement field name
    ' Export_Folder_Name = where to export the picture

    Dim db As Database
    Dim rst_TQ As DAO.Recordset
    Dim rst_Pictures As DAO.Recordset
    
    Set db = CurrentDb
    
    ' the parent recordset.
    Set rst_TQ = db.OpenRecordset(TQ_Name)
  
    ' loop through it
    While Not rst_TQ.EOF
  
     
        ' the child recordset.
        Set rst_Pictures = rst_TQ.Fields(fld_Name).Value
 
        '  Loop through the attachments.
        While Not rst_Pictures.EOF
  
            ' Save current attachment to disk, with their original names
            rst_Pictures.Fields("FileData").SaveToFile Export_Folder_Name
      
            rst_Pictures.MoveNext
        Wend
    
        rst_TQ.MoveNext
   Wend
   
   
Exit_Export_Attached_Pictures:

    rst_TQ.Close: Set rst_TQ = Nothing
    rst_Pictures.Close: Set rst_Pictures = Nothing
    
    Exit Function
    
err_Export_Attached_Pictures:

    If Err.Number = 3839 Then
        'file exists
        Resume Next
    ElseIf Err.Number = 91 Or Err.Number = 3420 Then
        Resume Next
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
        Resume Exit_Export_Attached_Pictures
    End If
    
End Function

.

ثم نادها هكذا :

لجميع صور الجدول
الجدول t
الحقل Pic
مسار مجلد الحفظ D:\Test
call Export_Attached_Pictures("t","Pic","D:\Test")

لجميع صور الاستعلام
الاستعلام 11
call Export_Attached_Pictures("11","Pic","D:\Test")

.

 

وفي هذا الرابط شرح لنفس الكود اعلاه ، ولكن لحفظ المرفقات ، كُلاً في مجلده :

 

.

وهنا رابط حذف المرفقات :

 

 

جعفر

 

 

1256.برنامج لحفظ صور القاعدة داخل مجلد.zip

[kanory]

وهذه طريقة أخرى مشاركة مع العمدة @jjafferr

Sub SaveAttachmentAll(Optional FilePath)
    On Error Resume Next
    Dim Rs As DAO.Recordset, RsA As DAO.Recordset
    Dim NewFileName, Rc, Sn
    Set Rs = Me.RecordsetClone
    Rs.MoveFirst
    
    'Loop throu All record
    Do Until Rs.EOF
        'Set attachment db
        Set RsA = Rs("pic").Value
        
        'Get record count
        If RsA.RecordCount = 0 Then Exit Sub
        RsA.MoveLast
        Rc = RsA.RecordCount
        RsA.MoveFirst
        
        ' Loop throu current record attachments
        Do Until RsA.EOF
            ' make Sequence if more one attachment
            If Rc > 1 Then Sn = RsA.AbsolutePosition
            
            'if no file path provide, get db path
            If IsMissing(FilePath) Then
                FilePath = CurrentProject.Path & "\Images\"
            End If
            
            ' Make new file name
            NewFileName = Rs("جلوس") & Sn & "." & RsA("filetype")
             
            ' Save attached file to new file name
            RsA("FileData").SaveToFile FilePath & NewFileName
            RsA.MoveNext
        Loop
        Rs.MoveNext
    Loop
    Set Rs = Nothing
    Set RsA = Nothing
End Sub

ثم استدعيه من الزر

Call SaveAttachmentAll

 

kan.rar

تم تعديل سبتمبر 8, 2020 بواسطه kanory

[kanory]

2 ساعات مضت, jjafferr said:

 

1255.Export_Attached_Pictures.accdb.zip 49.73 kB · 1 تنزيلات

!!!! ؟؟؟؟ هل الملف المرفق له علاقة أم بداية اثار الكبر أخي @jjafferr

[jjafferr]

6 ساعات مضت, kanory said:

وهذه طريقة أخرى مشاركة مع العمدة

 

4 ساعات مضت, kanory said:

هل الملف المرفق له علاقة أم بداية اثار الكبر

 

عمدة وصغير ، ما يصير ، إلا اذا هامور 

شكرا على الملاحظة ، والتذكير (خليني اروح اشوف كم شعرة بقيت لي على الرأس ، هكذا نعمل تقدير عمر  )

 

وتم تغيير المرفق في المشاركة السابقة 🙂 

 

جعفر

[د.كاف يار]

اخي الكريم الواضح من كلامك انك تحتاج تحفظ مسار كل صورة في قاعدة البيانات

اذا كان هذا قصدك اتفضل هذا الكود انشاء الله يفي بالغرض

 

Dim Path As String
Path = "ضع هنا مسار الملجد"

Dim msg As String
        
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(Path)

For Each objFile In objFolder.files
msg = msg & vbNewLine & objFile.Path  ' ضع هنا عنصر التحكم الذي سيتم حفظ المسار اليه
Next objFile
 

 

[hamdy1111]

جزاكم الله خيرا جميعا على الاهتمام والرد

الاستاذ / ابو محمد  عبد الله

الاستاذ / جعفر

الاستاذ/ kanory

 (د كاف يار)

استاذتنا ومعلمينا المحترمين والموقع المتميز 

وكل من قرأ الموضوع 

 واسف لانقطاعي فترة طويلة لانشغالي وجاري التنفيذ