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

**jo_2010** · مايو 16

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

بعد التحية

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

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

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

Lab_2024.rar

**jo_2010** · مايو 17

**Foksh** · مايو 17

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

**jo_2010** · مايو 17

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

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

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

**Foksh** · مايو 17

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

**jo_2010** · مايو 17

منذ ساعه, Foksh said:

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

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

**سامي الحداد** · مايو 18

في 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** · مايو 18

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.png image.png.787ed2a2f3b2a4c548a1fdbe7bcdefb6.png image.png.de3a10f3255b22e9813fb6a4a84e3b44.png

تم تعديل مايو 18 بواسطه jo_2010

**Foksh** · مايو 18

أخي @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

تم تعديل مايو 18 بواسطه Foksh
توضيح السبب

**jo_2010** · مايو 18

منذ ساعه, 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

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

تسجيل الدخول

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

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

jo_2010

jo_2010

Foksh

jo_2010

Foksh

jo_2010

سامي الحداد

jo_2010

Foksh

jo_2010

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information