حذف الصفحات الفارغة من ملف وورد برمجيا

[طير البحر]

اخواني استخدم هذا الكود لحذف الصفحات الفارغة برمجيا من ملف وورد وحصلت على نسخ عديدة من الكوت من chat gpt 
لكن الامر لم يفلح وكل مرة الكود يسلك سلوك مختلف 
هل ساعدتموني 
اريد ان احذف الصفحات الفارغة من ملف وورد برمجيا 
وهذا الكود 
 

Sub DeleteEmptyPages()
    Dim objWord As Object
    Dim objDoc As Object
    Dim i As Integer

    Set objWord = CreateObject("Word.Application")
    objWord.Visible = False ' Make Word invisible

    ' Open the document
    Set objDoc = objWord.Documents.Open(CurrentProject.Path & "\PDFs\" & Forms!SCANTOPDF!fileno.Value & ".docx")

  ' Delete empty pages
For i = objDoc.content.ComputeStatistics(2) To 1 Step -1
    If IsPageEmpty(objDoc, i) Then
      objDoc.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i

        objDoc.Bookmarks("\page").Range.Delete ' Delete the page
        Exit For ' Exit the loop to avoid issues with deleted page numbering
    End If
Next i

    ' Save and close the document
    objDoc.Save
    objDoc.Close

    ' Quit Word
    objWord.Quit

    ' Release the objects
    Set objWord = Nothing
    Set objDoc = Nothing
End Sub
Function IsPageEmpty(doc As Object, pageNumber As Integer) As Boolean
    ' Check if the specified page is empty or contains only system-generated content
    Dim content As String
    Dim shape As Object
    Dim para As Object

    ' Get the content of the page
    content = doc.Range(doc.GoTo(What:=1, Which:=1, Count:=pageNumber).Start, doc.GoTo(What:=1, Which:=1, Count:=pageNumber).End).Text

    ' Check if the content is empty or only contains system-generated text (e.g., page breaks, section breaks, etc.)
    If Len(Trim(content)) > 50 Then
        ' If the content is not empty, check if it's only system-generated text
        For Each para In doc.Range(doc.GoTo(What:=1, Which:=1, Count:=pageNumber)).Paragraphs
            If para.Range.Information(wdActiveEndPageNumber) = pageNumber Then
                ' If the paragraph is on the specified page, check if it's system-generated
                If para.Range.Text Like "*(Page)*" Then
                    ' If it's system-generated text, continue to the next paragraph
                    ' You can add more conditions here to check for other system-generated text
                Else
                    ' If it's actual content, the page is not empty
                    IsPageEmpty = False
                    Exit Function
                End If
            End If
        Next para
    End If

    ' If no actual content is found, the page is empty
    IsPageEmpty = True
End Function

 

[Foksh]

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

Sub DeleteEmptyPages()
    Dim objWord As Object
    Dim objDoc As Object
    Dim i As Integer

    Set objWord = CreateObject("Word.Application")
    objWord.Visible = False ' Make Word invisible

    ' Open the document
    Set objDoc = objWord.Documents.Open(CurrentProject.Path & "\PDFs\" & Forms!SCANTOPDF!fileno.Value & ".docx")

    ' Delete empty pages
    For i = objDoc.content.ComputeStatistics(2) To 1 Step -1
        If IsPageEmpty(objDoc, i) Then
            objDoc.GoTo What:=1, Which:=1, Count:=i
            objDoc.Range.Delete
        End If
    Next i

    ' Save and close the document
    objDoc.Save
    objDoc.Close

    ' Quit Word
    objWord.Quit

    ' Release the objects
    Set objWord = Nothing
    Set objDoc = Nothing
End Sub

Function IsPageEmpty(doc As Object, pageNumber As Integer) As Boolean
    ' Check if the specified page is empty or contains only whitespace characters
    Dim content As String
    
    ' Get the content of the page
    content = doc.Range(doc.GoTo(1, 1, pageNumber).Start, doc.GoTo(1, 1, pageNumber).End).Text

    ' Check if the content is empty or only contains whitespace characters
    IsPageEmpty = Trim(content) = ""
End Function

طبعاً لم تتم تجربته

تم تعديل مارس 22 بواسطه Foksh

[طير البحر]

الاخ @Foksh لقد جربت اكثر من 100 اقتراح من chat gpt
لكنه مارس عليا الغباء الصناعي ههههه

[Foksh]

استخدام الذكاء الاصطناعي يحتاج اسلوب شرح وتوضيح معطيات كثيرة حتى تصل المطلوب منه. وهو يعطيك النتائج حسب الشرح المقدم له ، وقد تحتاج لذكر الاحتمالات جميعها له حتى يتجاوب معك بالشكل المطلوب 😅

[طير البحر]

اخي @Foksh ارجو ان استطعت المساعدة بمثال
 

[Foksh]

حالياً ليس لدي جهاز كمبيوتر ، لكن ليوم الغد إن شاء الله سأحاول ارفاق تجربة موثقة ، إن لم يسبقني أحد الاساتذة 😊

[سامي الحداد]

السلام عليكم 

هذه  مشاركتي مع الاخوة الكرام.

Option Compare Database
Option Explicit

Private Sub Command0_Click()
     CleanUpWordDocument
End Sub
Public Function DeleteBlankPages(wd As Word.Document)
    Dim par As Paragraph
    For Each par In wd.Paragraphs
        If Len(par.Range.Text) <= 1 Then
            par.Range.Delete
        End If
    Next par
End Function

Public Sub CleanUpWordDocument()
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    Set wdDoc = wdApp.Documents.Open("C:\Users\LENOVO\Documents\Test1.docx")' استبدل المسار 
    
    DeleteBlankPages wdDoc
    MsgBox "تمت عملية حذف الصفحات الفارغة", vbInformation + vbMsgBoxRight, "تأكيد"

    wdDoc.Save
    wdDoc.Close
    wdApp.Quit
    
    Set wdDoc = Nothing
    Set wdApp = Nothing
End Sub

بالتوفيق

[Foksh]

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

حالياً ليس لدي جهاز كمبيوتر ، لكن ليوم الغد إن شاء الله سأحاول ارفاق تجربة موثقة ، إن لم يسبقني أحد الاساتذة 😊

تفضل يا صديقي ، الكود بعد إجراء بعض التعديلات على كودي السابق وكود الأستاذ @سامي الحداد 

طبعاً يجب إضافة مكتبة
"Microsoft Word XX.X Object Library"
حيث XX.X هو إصدار مايكروسوفت أوفيس لديك 

Option Compare Database
Option Explicit
Option Base 1

Private Sub Command0_Click()
    CleanUpWordDocument
End Sub

Public Sub CleanUpWordDocument()
    Dim wdApp As Object
    Dim wdDoc As Object
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    On Error GoTo 0
    If wdApp Is Nothing Then
        Set wdApp = CreateObject("Word.Application")
    End If
    Set wdDoc = wdApp.Documents.Open(CurrentProject.Path & "\PDFs\" & Me.fileno.Value & ".docx")
    DeleteEmptyPages wdDoc
    wdDoc.Close True
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
    
    MsgBox "تمت عملية حذف الصفحات الفارغة", vbInformation + vbMsgBoxRight, "تأكيد"
End Sub

Public Sub DeleteEmptyPages(wdDoc As Object)
    Dim i As Long
    Dim pageCount As Long
    Dim rng As Object
    
    pageCount = wdDoc.Range.ComputeStatistics(2)
    
    For i = pageCount To 1 Step -1
        Set rng = wdDoc.GoTo(1, 1, i)
        If Len(Trim(rng.Text)) = 0 Then
            rng.Delete
        End If
    Next i
End Sub

 

01010.accdb

 

وأخبرني بالنتيجة

تم تعديل مارس 23 بواسطه Foksh

[طير البحر]

الاخ @سامي الحداد للاسف لم يؤدي الكود الوظيفة المرجوة
الاخ @Foksh الكود يحذف الحرف الاول من الفقرة الاولى اذا كانت فقرة وحيدة ويحذف الصور 
لقد مررت بكل هذه التجارب تقريبا او بتجارب مماثلة ولم اصل لنتيجة
اشكر مجهودكم والباب مازال مفتوحا لنصل لهذا الكود ننتفع به وننفع غيرنا

[سامي الحداد]

4 ساعات مضت, طير البحر said:

للاسف لم يؤدي الكود الوظيفة المرجوة

عجيب كيف لم  يؤدي الوظيفة؟ الا اذا كنت تقصد شيئا اخر ! ملاحظة برنامج Word يجب ان يكون مفلقا  حتى يتم عمل الكود.

انظر للفيديو المرفق

 

Delete Empty Word Pages.rar

[طير البحر]

18 hours ago, سامي الحداد said:

عجيب كيف لم  يؤدي الوظيفة؟ الا اذا كنت تقصد شيئا اخر ! ملاحظة برنامج Word يجب ان يكون مفلقا  حتى يتم عمل الكود.

انظر للفيديو المرفق

 

Delete Empty Word Pages.rar 1014.93 kB · 2 downloads

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

[سامي الحداد]

  

11 ساعات مضت, طير البحر said:

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

أخي  الكريم طلبك كان  حذف الصفحات الفارغة من ملف وورد برمجيا . 

وهذا ما تم عمله لحذف الصفحات الفارغه ولا له علاقة بطلبك الثاني . سوف اتوقف هنا.

تحياتي

[طير البحر]

9 hours ago, سامي الحداد said:

  

أخي  الكريم طلبك كان  حذف الصفحات الفارغة من ملف وورد برمجيا . 

وهذا ما تم عمله لحذف الصفحات الفارغه ولا له علاقة بطلبك الثاني . سوف اتوقف هنا.

تحياتي

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

[سامي الحداد]

10 ساعات مضت, طير البحر said:

ان طلبي محدد من البداية الصفخات الفارغة اى يجب ان تكون فارغة من اى محتوى

اخي الكريم

وهذا ما عملته بالضبط يجب ان تكون الصفحة خالية تماما من اي محتوى،،، والكود يقوم بهذه المهة فقط.

سؤال هل فعلا جربت الكود لإني على يقين حضرتك لم تجرب الكود. وإلا لكان رأيت عمل الكود بالضبط. 

الاخوة الكرام من يستطيع ان يجرب الكود ويعلمني اذا كان يعمل او لا . ربما اكون مخطئ.

وهذا الكود مرة اخرى 

Option Compare Database
Option Explicit
Private Sub Command0_Click()
     CleanUpWordDocument
End Sub
Public Function DeleteBlankPages(wd As Word.Document)
    Dim par As Paragraph
    For Each par In wd.Paragraphs
        If Len(par.Range.Text) <= 1 Then
            par.Range.Delete
        End If
    Next par
End Function
Public Sub CleanUpWordDocument()
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    Set wdDoc = wdApp.Documents.Open("C:\Users\LENOVO\Documents\Test1.docx")' استبدل المسار 
    
    DeleteBlankPages wdDoc
    MsgBox "تمت عملية حذف الصفحات الفارغة", vbInformation + vbMsgBoxRight, "تأكيد"
    wdDoc.Save
    wdDoc.Close
    wdApp.Quit
    
    Set wdDoc = Nothing
    Set wdApp = Nothing
End Sub

 

[طير البحر]

15 hours ago, سامي الحداد said:

اخي الكريم

وهذا ما عملته بالضبط يجب ان تكون الصفحة خالية تماما من اي محتوى،،، والكود يقوم بهذه المهة فقط.

سؤال هل فعلا جربت الكود لإني على يقين حضرتك لم تجرب الكود. وإلا لكان رأيت عمل الكود بالضبط. 

الاخوة الكرام من يستطيع ان يجرب الكود ويعلمني اذا كان يعمل او لا . ربما اكون مخطئ.

وهذا الكود مرة اخرى 

Option Compare Database
Option Explicit
Private Sub Command0_Click()
     CleanUpWordDocument
End Sub
Public Function DeleteBlankPages(wd As Word.Document)
    Dim par As Paragraph
    For Each par In wd.Paragraphs
        If Len(par.Range.Text) <= 1 Then
            par.Range.Delete
        End If
    Next par
End Function
Public Sub CleanUpWordDocument()
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    Set wdDoc = wdApp.Documents.Open("C:\Users\LENOVO\Documents\Test1.docx")' استبدل المسار 
    
    DeleteBlankPages wdDoc
    MsgBox "تمت عملية حذف الصفحات الفارغة", vbInformation + vbMsgBoxRight, "تأكيد"
    wdDoc.Save
    wdDoc.Close
    wdApp.Quit
    
    Set wdDoc = Nothing
    Set wdApp = Nothing
End Sub

 

نعم جربته وهو يحذف الصفحات الفارغة فعلا لكن المشكلة انه يعتبر الصفحات التى تحتوي على صور فقط فارغة ايضا ويقوم بحذف الصور 
تفضل فقط بادراج صورة فى احد الصفحات ثم انظر لسلوك الكود
لان الكود يبحث عن نص فى فقرة فاذا لم يجد نص فهو يعتبر الصفحة فارغة ويطبق امر الحذف delete وعند وجود صورة فى الصفحة فقط فهو يعتبرها فارغة وينفذ امر الحذف الذلي عندها يحذف الصورة فقط ويترك الصفخة خالية