مشكل المرفقات الكثيرة

[fedaa_elden]

السلام عليكم 

اخواني يوجد لدي قاعدة بينات احتاج ان ارفق بها الكثير من الملفات حتى بلغ حجمها حوالى 1 جيجا حتى الان 

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

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

مرفق لكم مثال من قاعدة البيانات 

ولكم جزيل الشكر 

 

لم استطع رفع المرفق على الموقع بسبب المساحة

تم تعديل مارس 25, 2020 بواسطه jjafferr
تم حذف الرابط

[jjafferr]

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

 

1. انت محتاج الى هذا الكود لنسخ المرفقات من قاعدة البيانات الى مجلد في الكمبيوتر :

'
'from
'https://docs.microsoft.com/en-us/office/vba/access/Concepts/Data-Access-Objects/work-with-attachments-in-dao
'

'  Instantiate the parent recordset.  
   Set rsEmployees = db.OpenRecordset("Employees") 
  
   'Code to move to desired employee 
  
   ' Instantiate the child recordset. 
   Set rsPictures = rsEmployees.Fields("Pictures").Value  
 
   '  Loop through the attachments. 
   While Not rsPictures.EOF 
  
      '  Save current attachment to disk in the "My Documents" folder. 
      rsPictures.Fields("FileData").SaveToFile _ 
                  "C:\Documents and Settings\Username\My Documents" 
      rsPictures.MoveNext 
   Wend

 

2. حذف حقول الرفقات من برنامجك ،

3. اذا عندك اكثر من مرفق لنفس السجل ، فالافضل ان تعرض اسماء المرفقات في النموذج ، والمستخدم ينقر على الصورة اللي يريده ، ويشوفها في النموذج :

 

.

جعفر

[fedaa_elden]

شكرا اخي جعفر على سرعة الرد

ولكن بعد اذنك لم استطع الفهم جيدا حيث انى جديد فى برنامج الاكسس كما ان اغلب المرفقات لدي من نوع ( مستندات ) فهل من الممكن ان تشرح لى فى الملف المرفق على رابط الدرايف 

 

ولكم جزيل الشكر

تم تعديل مارس 25, 2020 بواسطه jjafferr
تم حذف الرابط

[jjafferr]

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

 

1. رجاء انزل البرنامج المرفق ، ثم انسخ الكائنين منه الى برنامجك الرئيسي ، واحذف البرنامج المرفق ، ثم العمل على نسخة من برنامجك الاصلي ،

2. تأكد ان جميع النماذج مغلقه ، ثم افتح النموذج zfrm_Testing ، وانقر على الزر

.

3. هذا سيعمل مجلدات في مجلد  برنامجك ، وفي كل مجلد المرفقات التي به (حسب ID سجل برنامجك) ،
وسيقوم بتصدير جميع مرفقاتك الى المجلدات :

.

4. لما ينتهي البرنامج من تصدير الملفات ، سيعطيك رسالة Done ،

5. افتح النموذج Masttr Form2 ، وسترى المرفقات موجودة على يمين الشاشة (انظر للصورة في الاسفل) ،

6. المرفقات في الاعلى تابعة للنموذج الرئيسي ، والمرفقات في الاسفل تابعة للنموذج الفرعي (رجاء التاكد ان المرفقات صحيحة ، وهي نفسها الموجودة في برنامجك) :

.

• انا لم اقم بعمل كود لحذف اي شيء من برنامجك ،
• اذا اردت ان تضيف مرفق جديد ، فتستطيع ان تمسكه من متصفح الملفات ، وتفلته Drag and Drop سواء في المجلد العلوي او السفلي ،
• البرنامج تلقائيا يضيف المجلدات.

بعد ان تتأكد ان البرنامج يعمل بطريقة صحيحة ، تستطيع يدويا ان تحذف حقول المرفقات من جدوليك ، ثم استعمل ضغط واصلاح 🙂

 

هذا هو الكود الموجود في النموذج zfrm_Testing ، والذي يصدر المرفقات الى مجلدات و ملفات خارجية :

Private Sub cmd_Export_Attachments_Click()
On Error GoTo err_cmd_Export_Attachments_Click


    Dim rst_tbl As DAO.Recordset
    Dim rst_Att As DAO.Recordset
    Dim myDir As String
    Dim File_Name As String
    
    'table name            : [Mastr Table]
    'Attachment filed name : [مرفقات]
   
    Set rst_tbl = CurrentDb.OpenRecordset("Select * From [Mastr Table]")
 
    
    While Not rst_tbl.EOF       '  Loop through the table
            
            
        'check if the Dir exists, if not, make it
        myDir = Application.CurrentProject.Path & "\Attachments"  'Attachments
         Call Make_Dir(myDir)
        
        myDir = myDir & "\Mastr_Table"                            'Mastr_Table
         Call Make_Dir(myDir)
        
'        myDir = myDir & "\" & rst_tbl![CUSTOMER COD]              'Customer_Code
'         Call Make_Dir(myDir)
        
        myDir = myDir & "\" & rst_tbl!ID                            'ID
         Call Make_Dir(myDir)
        

        Set rst_Att = rst_tbl.Fields("[مرفقات]").Value
        While Not rst_Att.EOF                                                       '  Loop through the attachments.
'            File_Name = myDir & "\" & rst_tbl!ID & "_" & rst_Att.Fields("Filename") 'ID and Attachment names
'            rst_Att.Fields("FileData").SaveToFile File_Name                         '  Save current attachment
            rst_Att.Fields("FileData").SaveToFile myDir
            rst_Att.MoveNext
        Wend    'rst_Att
   
   
        rst_tbl.MoveNext
    Wend        'rst_tbl
   
   
   
''
   '
   '[Payment Table]
   '[مرفقات]
   
    Set rst_tbl = CurrentDb.OpenRecordset("Select * From [Payment Table]")
 
    
    While Not rst_tbl.EOF       '  Loop through the table
            
            
        'check if the Dir exists, if not, make it
        myDir = Application.CurrentProject.Path & "\Attachments"  'Attachments
         Call Make_Dir(myDir)
        
        myDir = myDir & "\Payment_Table"                            'Mastr_Table
         Call Make_Dir(myDir)
        
'        myDir = myDir & "\" & rst_tbl![CUSTOMER COD]              'Customer_Code
'         Call Make_Dir(myDir)
        
        myDir = myDir & "\" & rst_tbl!ID                            'ID
         Call Make_Dir(myDir)
        

        Set rst_Att = rst_tbl.Fields("[مرفقات]").Value
        While Not rst_Att.EOF                                                       '  Loop through the attachments.
'            File_Name = myDir & "\" & rst_tbl!ID & "_" & rst_Att.Fields("Filename") 'ID and Attachment names
'            rst_Att.Fields("FileData").SaveToFile File_Name                         '  Save current attachment
            rst_Att.Fields("FileData").SaveToFile myDir
            rst_Att.MoveNext
        Wend    'rst_Att
   
   
        rst_tbl.MoveNext
    Wend        'rst_tbl
   
   
   
    rst_tbl.Close: Set rst_tbl = Nothing
    rst_Att.Close: Set rst_Att = Nothing
    
Exit_cmd_Export_Attachments_Click:
    
    MsgBox "Done"
    
Exit Sub
err_cmd_Export_Attachments_Click:

    If Err.Number = 3420 Then
        'ignore rst not there
        Resume Next
        
    ElseIf Err.Number = 3839 Then
        'file exists
        Resume Next
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    

End Sub

Public Function Make_Dir(Dir_Name As String) As Boolean

    'Make_Dir = True  ' a new Directory was made
    'Make_Dir = False ' the Directory Exists
    
        'check if the Dir exists, if not, make it
        If Dir(Dir_Name, vbDirectory) = "" Then
            MkDir Dir_Name
            Make_Dir = True ' a new Directory was made
        End If
        
End Function

.

وهذا كود لحدث الحالي والذي يُظهر المرفقات في كائن webbrowser في النموذج Masttr Form2 :

    
    Dim myDir As String
    
    'Mastr_Table, Dir exists, if not, make it
    myDir = Application.CurrentProject.Path & "\Attachments"  'Attachments
     Call Form_zfrm_Testing.Make_Dir(myDir)

    myDir = myDir & "\Mastr_Table"                            'Mastr_Table
     Call Form_zfrm_Testing.Make_Dir(myDir)

    myDir = myDir & "\" & Me!ID                               'ID
     Call Form_zfrm_Testing.Make_Dir(myDir)

    'Payment_Table, Dir exists, if not, make it
    myDir = Application.CurrentProject.Path & "\Attachments"  'Attachments
     Call Form_zfrm_Testing.Make_Dir(myDir)

    myDir = myDir & "\Payment_Table"                            'Payment_Table
     Call Form_zfrm_Testing.Make_Dir(myDir)

    myDir = myDir & "\" & Me!ID                                'ID
     Call Form_zfrm_Testing.Make_Dir(myDir)
         
         
         
    'specify that the browser is an object in the Form
    Set web = Me.objIE.Object
    Set web_2 = Me.objIE_2.Object
    
    'Master, Open/Navigate the page
    myDir = Application.CurrentProject.Path & "\Attachments"  'Attachments
    myDir = myDir & "\Mastr_Table"                            'Mastr_Table
    myDir = myDir & "\" & Me!ID
    
    web.Navigate myDir
    
    
    'Payment, Open/Navigate the page
    myDir = Application.CurrentProject.Path & "\Attachments"  'Attachments
    myDir = myDir & "\Payment_Table"                            'Mastr_Table
    myDir = myDir & "\" & Me!ID
    
    web_2.Navigate myDir
 

 

جعفر

1195.zip

[أبوبسمله]

ماشاء الله ولا قوه الا بالله بارك الله فيك وجزاك الله خيرا اخى واستاذى ومعلمنا الغالى @jjafferr

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

تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق