نقل الصور من حقل Attachment في Access إلى مجلد باستخدام VBA
نعم، يمكنك نقل الصور من حقل Attachment في Access إلى مجلد مجاور للبرنامج باستخدام كود VBA. إليك كيفية القيام بذلك:
كود VBA لنسخ الملفات المرفقة إلى مجلد
كيفية استخدام الكود
استبدل "اسم_جدولك" باسم الجدول الذي يحتوي على حقل المرفقات
استبدل "اسم_حقل_المرفقات" باسم حقل Attachment في جدولك
سيتم إنشاء مجلد يسمى "Attachments" بجوار ملف قاعدة البيانات إذا لم يكن موجوداً
سيتم حفظ جميع الملفات المرفقة في هذا المجلد
ملاحظات مهمة
الكود يتعامل مع جميع أنواع الملفات المرفقة، ليس فقط الصور
يتم إنشاء أسماء ملفات فريدة لتجنب الكتابة فوق الملفات الموجودة
يتم تخطي الملفات المخفية مثل Thumbs.db
تأكد من أن لديك أذونات الكتابة في المجلد الهدف
يمكنك تعديل الكود حسب احتياجاتك الخاصة، مثل تصفية أنواع ملفات معينة (مثل .jpg, .png فقط) أو تنظيم الملفات في مجلدات فرعية.
واليك الكود :-
Sub ExportAttachmentsToFolder()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsAttach As DAO.Recordset2
Dim fldAttach As DAO.Field2
Dim strFilePath As String
Dim strFileName As String
Dim strFullPath As String
Dim strFolderPath As String
Dim i As Integer
' تحديد مسار المجلد الهدف (بجوار قاعدة البيانات)
strFolderPath = CurrentProject.Path & "\Attachments\"
' إنشاء المجلد إذا لم يكن موجوداً
If Dir(strFolderPath, vbDirectory) = "" Then
MkDir strFolderPath
End If
' فتح جدول أو استعلام يحتوي على حقل المرفقات
Set db = CurrentDb()
Set rs = db.OpenRecordset("اسم_جدولك") ' استبدل باسم الجدول الفعلي
' تحديد حقل المرفقات
Set fldAttach = rs.Fields("اسم_حقل_المرفقات") ' استبدل باسم حقل المرفقات
' التكرار خلال السجلات
Do Until rs.EOF
' فتح سجل المرفقات للسجل الحالي
Set rsAttach = fldAttach.Value
' التكرار خلال المرفقات في السجل الحالي
i = 0
Do Until rsAttach.EOF
' تجنب الملفات المخفية (مثل thumbs.db)
If Not (rsAttach.Fields("FileName") Like "~*" Or _
rsAttach.Fields("FileName") = "Thumbs.db") Then
' إنشاء اسم فريد للملف لمنع التكرار
strFileName = rsAttach.Fields("FileName")
strFullPath = strFolderPath & strFileName
' التأكد من عدم وجود ملف بنفس الاسم
While Dir(strFullPath) <> ""
i = i + 1
strFullPath = strFolderPath & i & "_" & strFileName
Wend
' حفظ المرفق إلى الملف
rsAttach.Fields("FileData").SaveToFile strFullPath
End If
rsAttach.MoveNext
Loop
rsAttach.Close
rs.MoveNext
Loop
' تنظيف الذاكرة
rs.Close
Set rsAttach = Nothing
Set fldAttach = Nothing
Set rs = Nothing
Set db = Nothing
MsgBox "تم تصدير المرفقات بنجاح إلى: " & strFolderPath, vbInformation
End Sub