اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

تصحيح كود حذف مرفقات

jo_2010

بواسطه jo_2010
في قسم الأكسيس Access

 مشاركة
إذهب إلى أفضل إجابة Solved by Foksh,

الردود الموصى بها

jo_2010

jo_2010

قام بنشر
قام بنشر

الخبراء الافاضل

بعد التحية

مرفق نموذج للتعديل علية 

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

المطلوب: اريد حذفها من الفولدر الخاص بها واذا كان الفولدر فارغ يتم حذف الفولدر ايضا

Lab_2024.rar

رابط هذا التعليق
شارك
jo_2010

jo_2010

قام بنشر
  • الكاتب
قام بنشر
4 ساعات مضت, Foksh said:

استخدم التعبير Kill ثم المسار أو اسم مربع النص الذي يحتوي على المسار قبل جملة الحذف من الجدول 👍

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

رابط هذا التعليق
شارك
jo_2010

jo_2010

قام بنشر
  • الكاتب
قام بنشر
منذ ساعه, Foksh said:

بحكم اني بعيد عن الكمبيوتر هذه الفترة بسبب العمل ، لكن إن سمحت لي الزروف الليلة بتابع معك .

خالص الشكر علي اهتمامك ربنا يعينك في عملك ويزيدك  فى علمك

  • Thanks 1
رابط هذا التعليق
شارك
سامي الحداد

سامي الحداد

قام بنشر
قام بنشر
في 16‏/5‏/2024 at 18:02, jo_2010 said:

المطلوب: اريد حذفها من الفولدر الخاص بها واذا كان الفولدر فارغ يتم حذف الفولدر ايضا

مشاركة  مع الاخ العزيز @Foksh

اليك التعديل والاضافة على الكود 

Private Sub Del_Click()
    On Error Resume Next
  
    If IsNull(Me.MyList) Then
        MsgBox "يجب اختيار الملف اولا " & vbNewLine & vbNewLine & " اختـار اسـم الملـف من القائمة", vbCritical + vbMsgBoxRight, "تنبيه"
    Else
        Dim sSQL As String
        Dim aFile As String
        Dim folderPath As String
        Dim FDS_path As String
        Dim fso As Object
        Dim FileCount As Integer
        
        aFile = DLookup("[Attachment_Path]", "[tbl_AttachmentList]", "[Attachment_NO]=[forms]![Attacheds]![MyList]")
        folderPath = Left(aFile, InStrRev(aFile, "\") - 1)
        FDS_path = Left(folderPath, InStrRev(folderPath, "\") - 1)
       
        If MsgBox("هل تريد حذف المرفق ؟", vbYesNo + vbMsgBoxRight + vbCritical) = vbYes Then
            Kill aFile
         
            Set DB = CurrentDb
            sSQL = "DELETE FROM tbl_AttachmentList WHERE [Attachment_NO]= " & Me.MyList
            DB.Execute sSQL
            
            MsgBox "تم حذف المرفق ... بنجاح", vbInformation + vbMsgBoxRight, "تأكيد"
            Me.MyList.Requery
            Me.Show_Files.Requery
            Set fso = CreateObject("Scripting.FileSystemObject")
            If fso.FolderExists(FDS_path) Then
            DeleteEmptySubfolders fso, FDS_path
                
                If fso.GetFolder(FDS_path).Files.Count = 0 And fso.GetFolder(FDS_path).SubFolders.Count = 0 Then
                    fso.DeleteFolder FDS_path, True
                End If
            End If
            Set fso = Nothing
        End If
    End If
End Sub


Private Sub DeleteEmptySubfolders(fso As Object, folderPath As String)
    Dim folder As Object
    Dim subFolder As Object
    
    Set folder = fso.GetFolder(folderPath)
    
    For Each subFolder In folder.SubFolders
        DeleteEmptySubfolders fso, subFolder.Path
        If fso.GetFolder(subFolder.Path).Files.Count = 0 And fso.GetFolder(subFolder.Path).SubFolders.Count = 0 Then
        fso.DeleteFolder subFolder.Path, True
        End If
    Next subFolder
End Sub

والملف بعد التعديل

بالتوفيق

Lab_2024 - 2.rar

رابط هذا التعليق
شارك
jo_2010

jo_2010

قام بنشر
  • الكاتب
قام بنشر (معدل)
1 ساعه مضت, سامي الحداد said:

مشاركة  مع الاخ العزيز @Foksh

اليك التعديل والاضافة على الكود 

Private Sub Del_Click()
    On Error Resume Next
  
    If IsNull(Me.MyList) Then
        MsgBox "يجب اختيار الملف اولا " & vbNewLine & vbNewLine & " اختـار اسـم الملـف من القائمة", vbCritical + vbMsgBoxRight, "تنبيه"
    Else
        Dim sSQL As String
        Dim aFile As String
        Dim folderPath As String
        Dim FDS_path As String
        Dim fso As Object
        Dim FileCount As Integer
        
        aFile = DLookup("[Attachment_Path]", "[tbl_AttachmentList]", "[Attachment_NO]=[forms]![Attacheds]![MyList]")
        folderPath = Left(aFile, InStrRev(aFile, "\") - 1)
        FDS_path = Left(folderPath, InStrRev(folderPath, "\") - 1)
       
        If MsgBox("هل تريد حذف المرفق ؟", vbYesNo + vbMsgBoxRight + vbCritical) = vbYes Then
            Kill aFile
         
            Set DB = CurrentDb
            sSQL = "DELETE FROM tbl_AttachmentList WHERE [Attachment_NO]= " & Me.MyList
            DB.Execute sSQL
            
            MsgBox "تم حذف المرفق ... بنجاح", vbInformation + vbMsgBoxRight, "تأكيد"
            Me.MyList.Requery
            Me.Show_Files.Requery
            Set fso = CreateObject("Scripting.FileSystemObject")
            If fso.FolderExists(FDS_path) Then
            DeleteEmptySubfolders fso, FDS_path
                
                If fso.GetFolder(FDS_path).Files.Count = 0 And fso.GetFolder(FDS_path).SubFolders.Count = 0 Then
                    fso.DeleteFolder FDS_path, True
                End If
            End If
            Set fso = Nothing
        End If
    End If
End Sub


Private Sub DeleteEmptySubfolders(fso As Object, folderPath As String)
    Dim folder As Object
    Dim subFolder As Object
    
    Set folder = fso.GetFolder(folderPath)
    
    For Each subFolder In folder.SubFolders
        DeleteEmptySubfolders fso, subFolder.Path
        If fso.GetFolder(subFolder.Path).Files.Count = 0 And fso.GetFolder(subFolder.Path).SubFolders.Count = 0 Then
        fso.DeleteFolder subFolder.Path, True
        End If
    Next subFolder
End Sub

والملف بعد التعديل

بالتوفيق

Lab_2024 - 2.rar 1.5 \u0645\u064a\u062c\u0627 \u0628\u0627\u064a\u062a · 1 download

الاستاذ الفاضل والمعلم ا لفاضل

لم اجد اى تغيير مسحت ملف Pdf تم حذفة من الجدول ولكنة موجود فى فولدر الملفات   

ملجوظة

Foxit PhantomPDF  انا استخدم هذا البرنامج بدل من برنامج  الاكروبات

image.png.6f39d8176b5333ae1cc10abe699f930a.pngimage.png.787ed2a2f3b2a4c548a1fdbe7bcdefb6.pngimage.png.de3a10f3255b22e9813fb6a4a84e3b44.png

تم تعديل بواسطه jo_2010
رابط هذا التعليق
شارك
  • أفضل إجابة
Foksh

Foksh

قام بنشر
  • أفضل إجابة
قام بنشر (معدل)

أخي @jo_2010 ، جرب هذا الكود ؟؟

مع العلم أن كود الأستاذ @سامي الحداد يعمل بنجاح بعد تجربتي له ، ولكنني أعتقد أنك تواجه مشكلة في حذف ملفات الـ PDF خصوصاً ..

والسبب هو أن برنامج Acrobat Reader يعمل في الخلفية في الويندوز لديك وهو بدوره يقوم بفتح الملف عنط طريقه كوسيط في النموذج لديك ، وبذلك فأنت تحاول حذف ملف محجوز ومفتوح ومشغول من قبل مستخدم آخر . وطبعاً في حال تم اغلاق البرنامج الوسيط فإنه لا يمكنك عرض ملفات الـ PDF في النموذج إلا بعد عمل إعادة تشغيل للويندوز .

 

طبعاً هذا من وجهة نظري ، والله أعلم 

Private Sub Del_Click()
    On Error GoTo ErrHandler
    If IsNull(Me.MyList) Then
        MsgBox "يجب اختيار الملف أولاً" & vbNewLine & vbNewLine & "اختـار اسـم الملـف من القائمـة", vbCritical + vbMsgBoxRight, "تنبيه"
        Exit Sub
    End If
    Dim sSQL As String
    Dim FLS_Path As String
    Dim FDS_path As String
    Dim MainFolderPath As String
    Dim fso As Object
    Dim FileCount As Integer
    Dim FolderCount As Integer
    FLS_Path = DLookup("[Attachment_Path]", "[tbl_AttachmentList]", "[Attachment_NO]=[forms]![Attacheds]![MyList]")
    If FLS_Path = "" Then
        MsgBox "لم يتم العثور على الملف المحدد", vbCritical + vbMsgBoxRight, "خطأ"
        Exit Sub
    End If
    FDS_path = Left(FLS_Path, InStrRev(FLS_Path, "\") - 1)
    MainFolderPath = Left(FDS_path, InStrRev(FDS_path, "\") - 1)
    If MsgBox("هل تريد حذف المرفق؟", vbYesNo + vbMsgBoxRight + vbCritical) = vbYes Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Me.Show_Files.SourceObject = ""
        If fso.FileExists(FLS_Path) Then
            fso.DeleteFile FLS_Path, True
        Else
            MsgBox "الملف المحدد غير موجود أو قد تم حذفه مسبقاً.", vbExclamation + vbMsgBoxRight, "خطأ"
            Exit Sub
        End If
        Set DB = CurrentDb
        sSQL = "DELETE FROM tbl_AttachmentList WHERE [Attachment_NO]= " & Me.MyList
        DB.Execute sSQL
        FileCount = 0
        FolderCount = 0
        If fso.FolderExists(FDS_path) Then
            Dim file As Object
            Dim subFolder As Object
            For Each file In fso.GetFolder(FDS_path).Files
                FileCount = FileCount + 1
            Next file
            For Each subFolder In fso.GetFolder(FDS_path).SubFolders
                FolderCount = FolderCount + 1
            Next subFolder
            If FileCount = 0 And FolderCount = 0 Then
                fso.DeleteFolder FDS_path, True
            End If
        End If
        FileCount = 0
        FolderCount = 0
        If fso.FolderExists(MainFolderPath) Then
            For Each file In fso.GetFolder(MainFolderPath).Files
                FileCount = FileCount + 1
            Next file
            For Each subFolder In fso.GetFolder(MainFolderPath).SubFolders
                FolderCount = FolderCount + 1
            Next subFolder
            If FileCount = 0 And FolderCount = 0 Then
                fso.DeleteFolder MainFolderPath, True
            End If
        End If
        MsgBox "تم حذف المرفق بنجاح", vbInformation + vbMsgBoxRight, "تأكيد"
        Me.MyList.Requery
    End If
    Exit Sub
ErrHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical, "خطأ"
End Sub

 

تم تعديل بواسطه Foksh
توضيح السبب
رابط هذا التعليق
شارك
jo_2010

jo_2010

قام بنشر
  • الكاتب
قام بنشر
منذ ساعه, Foksh said:

أخي @jo_2010 ، جرب هذا الكود ؟؟

مع العلم أن كود الأستاذ @سامي الحداد يعمل بنجاح بعد تجربتي له ، ولكنني أعتقد أنك تواجه مشكلة في حذف ملفات الـ PDF خصوصاً ..

والسبب هو أن برنامج Acrobat Reader يعمل في الخلفية في الويندوز لديك وهو بدوره يقوم بفتح الملف عنط طريقه كوسيط في النموذج لديك ، وبذلك فأنت تحاول حذف ملف محجوز ومفتوح ومشغول من قبل مستخدم آخر . وطبعاً في حال تم اغلاق البرنامج الوسيط فإنه لا يمكنك عرض ملفات الـ PDF في النموذج إلا بعد عمل إعادة تشغيل للويندوز .

 

طبعاً هذا من وجهة نظري ، والله أعلم 

Private Sub Del_Click()
    On Error GoTo ErrHandler
    If IsNull(Me.MyList) Then
        MsgBox "يجب اختيار الملف أولاً" & vbNewLine & vbNewLine & "اختـار اسـم الملـف من القائمـة", vbCritical + vbMsgBoxRight, "تنبيه"
        Exit Sub
    End If
    Dim sSQL As String
    Dim FLS_Path As String
    Dim FDS_path As String
    Dim MainFolderPath As String
    Dim fso As Object
    Dim FileCount As Integer
    Dim FolderCount As Integer
    FLS_Path = DLookup("[Attachment_Path]", "[tbl_AttachmentList]", "[Attachment_NO]=[forms]![Attacheds]![MyList]")
    If FLS_Path = "" Then
        MsgBox "لم يتم العثور على الملف المحدد", vbCritical + vbMsgBoxRight, "خطأ"
        Exit Sub
    End If
    FDS_path = Left(FLS_Path, InStrRev(FLS_Path, "\") - 1)
    MainFolderPath = Left(FDS_path, InStrRev(FDS_path, "\") - 1)
    If MsgBox("هل تريد حذف المرفق؟", vbYesNo + vbMsgBoxRight + vbCritical) = vbYes Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Me.Show_Files.SourceObject = ""
        If fso.FileExists(FLS_Path) Then
            fso.DeleteFile FLS_Path, True
        Else
            MsgBox "الملف المحدد غير موجود أو قد تم حذفه مسبقاً.", vbExclamation + vbMsgBoxRight, "خطأ"
            Exit Sub
        End If
        Set DB = CurrentDb
        sSQL = "DELETE FROM tbl_AttachmentList WHERE [Attachment_NO]= " & Me.MyList
        DB.Execute sSQL
        FileCount = 0
        FolderCount = 0
        If fso.FolderExists(FDS_path) Then
            Dim file As Object
            Dim subFolder As Object
            For Each file In fso.GetFolder(FDS_path).Files
                FileCount = FileCount + 1
            Next file
            For Each subFolder In fso.GetFolder(FDS_path).SubFolders
                FolderCount = FolderCount + 1
            Next subFolder
            If FileCount = 0 And FolderCount = 0 Then
                fso.DeleteFolder FDS_path, True
            End If
        End If
        FileCount = 0
        FolderCount = 0
        If fso.FolderExists(MainFolderPath) Then
            For Each file In fso.GetFolder(MainFolderPath).Files
                FileCount = FileCount + 1
            Next file
            For Each subFolder In fso.GetFolder(MainFolderPath).SubFolders
                FolderCount = FolderCount + 1
            Next subFolder
            If FileCount = 0 And FolderCount = 0 Then
                fso.DeleteFolder MainFolderPath, True
            End If
        End If
        MsgBox "تم حذف المرفق بنجاح", vbInformation + vbMsgBoxRight, "تأكيد"
        Me.MyList.Requery
    End If
    Exit Sub
ErrHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical, "خطأ"
End Sub

 

الخبير المبدع الذى لايبخل بعلمة على احد        شكـــــــــرااااااا

  • Thanks 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept