إزالة المسافات الزائدة فى ملف الوورد

[seberbay4all]

السلام عليكم ورحمة الله

حقيقة لا أعرف كيف أشكر القائمين على هذا الصرح الرائع

ولي سؤال يتعلق بأنني اعمل كثيراً على الورد وأحتاج أن أعرف ما هو الأمر الذي يسمح لي بأن أقوم بالتالي:

في بعض الملفات التي أعمل عليها يكون في الملف فواصل (بمسطرة المسافات) أكثر من اللازم

فأقم بالضغط على Ctrl+H وأكتب بالأعلى: (مسافتين)، ثم أكتب في الأسفل: (مسافة واحدة)

فيبحث البرنامج ويقول لي تم استبدال كذا

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

==================

قمت بتسجيل ماكرو ليقوم هو بالخطوات ألياً:

وهاهو الكود الذي سجلته:

Sub ماكرو2()

'

' ماكرو2 ماكرو

' تسجيل الماكرو ‏01‏/08‏/2009 من قبل Windows AnGeL Live

'

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = " "

.Replacement.Text = " "

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchKashida = False

.MatchDiacritics = False

.MatchAlefHamza = False

.MatchControl = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

With Selection.Find

.Text = " "

.Replacement.Text = " "

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchKashida = False

.MatchDiacritics = False

.MatchAlefHamza = False

.MatchControl = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

End Sub

===================

المشكلة هي

أنه عندما يبحث في المرة الأولى يخبرني أنه أجرى مثلا 10 استبدالاً

ولكنه لا يبدأ في البحث مرة أخرى حتى أضغط على الزر Enter (موافق)

فهل من كود أضعه بين الخطوتين حتى يقوم هو آلياً بالضغط على Enter؟

================

معذرة على الإطالة ولكن هذا من حسن ظني بكم وبسعة صدركم

[محمد طاهر عرفه]

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

Sub replaceit()

Dim chrcount As Long

nexttt:

Selection.WholeStory


chrcount = Selection.Characters.Count


For i = 1 To chrcount - 1

Application.StatusBar = "Searching  ...." & _

             i & "/" & chrcount & "       Please Wait......."


 If Selection.Characters(i).Text = " " Then

  If Selection.Characters(i + 1).Text = " " Then

   Selection.Characters(i + 1).Text = ""

   chrcount = chrcount - 1

   GoTo nexttt

  End If

 End If


Next i

End Sub

[محمد طاهر عرفه]

هذا الملف يحتوي ثلاثة أكواد مختلفة

Delete Extra space.rar

الاول removeaddspace وهو كود مطور عن الكود السابق ويمتاز عنه بأنه لا يعيد البحث من البداية بعد كل حذف ويعطيك رسالة بعدد المسافات التي تم حذفها عند نهاية التنفيذ

الكود الثاني removespaceafterWa وهو كود مماثل مصمم للتغلب على مشكلة الواو التي تأتي فى نهاية السطر ويرفضها البعض من حيث الشكل، لذا يقوم الكود بحذف المسافات الزائدة التى تليها فلا يمكن أن تأتي كآخر كلمة فى السطر

الكود الثالث removeallspaces يقوم بتنفيذ الكودين السابقين على التوالى

Sub removeaddspace()

' code written by Mohamed Taher

' Purpose is to remove additional successive spaces (more than one space)


Dim chrcount, curpos, mycount As Long

curpos = 1

Selection.WholeStory

chrcount = Selection.Characters.Count

'MsgBox chrcount


Nextspace:



For i = curpos To chrcount

Application.StatusBar = "Removing extra spaces" & _

             i & "/" & chrcount & "       Please Wait......."


 If Selection.Characters(i).Text = " " Then

  If Selection.Characters(i + 1).Text = " " Then

   Selection.Characters(i + 1).Text = ""

   mycount = mycount + 1

   chrcount = chrcount - 1

   curpos = i

   GoTo Nextspace

  End If

 End If


Next i


MsgBox "no. of spaces removed = " & mycount & Chr(10) & Chr(13) & "  Best Wishes from Officena" & Chr(13) & " www.officena.net "

End Sub

Sub removespaceafterWa()

' code written by Mohamed Taher

' Purpose is to remove additional successive spaces (more than one space)


Dim chrcount, curpos, mycount As Long

curpos = 1

Selection.WholeStory

chrcount = Selection.Characters.Count

'MsgBox chrcount


Nextspace:



For i = curpos To chrcount

Application.StatusBar = " removing extra spaces after Wa" & _

             i & "/" & chrcount & "       Please Wait......."


 If Selection.Characters(i).Text = " " Then

  If Selection.Characters(i + 1).Text = "æ" And Selection.Characters(i + 2).Text = " " Then

   Selection.Characters(i + 2).Text = ""

   mycount = mycount + 1

   chrcount = chrcount - 1

   curpos = i

   GoTo Nextspace

  End If

 End If


Next i


MsgBox "no. of spaces afer Wawo  removed = " & mycount & Chr(10) & Chr(13) & "  Best wishes From Officena site " & Chr(10) & Chr(13) & " www.officena.net "

End Sub

Sub removeallspaces()

 Call removeaddspace

 Call removespaceafterWa

End Sub

Delete Extra space.rar

[seberbay4all]

جزاك الله كل خير .. وأعجز عن شكرك على هذه الأكواد

وأعتذر عن التأخر في الرد .. فقد دخلت مرة قبل ذلك ونسخت الكود الموجود في الرد الأول ثم خرجت وجربته فكانت مشكلته طول الوقت الذي يستغرقه في العمل

ولم أدخل المنتدى لأرد على الموضوع إلا الآن فاعذرني

وتقبل شكري وتحياتي

[seberbay4all]

سؤال لو تكرمت:

هل يمكن إضافة سطر برمجي في نهاية الماكرو ليقوم بحفظ التغييرات التي حدثت في ملف الورد؟

[seberbay4all]

حصلت على أمر الحفظ والحمد لله

جزيت خيرا

نضيف هذا السطر إلى نهاية الماكرو

ActiveDocument.Save