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

[المستشار22]

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

اشكر القائمين على هذ المنتدى الاكثر من رائع

كما اشكر الاخ ابو اكرم فهو من قام بعمل هذا الماكرو الموجود عندي الان ..

والسؤال كماهو واضح امامكم (( لدي ماكرو ولدي اكثر من 300 ملف وورد ويلزمني ان افتح كل ملف واشغل الماكرو فاحتاج الى وقت طويل

فهل هناك طريقة بان اشغل الماكرو على جميع الملفات دفعة واحدة)")

وجزاكم الله خير واشكركم مرة اخرى

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

لتشغيل ماكرو معين على أكثر من ملف موجود فى مجلد واحد

Sub ProcessAll()


    Dim Wb As Document, sFile As String, sPath As String

    Dim itm As Variant

    Dim strFileNames  As String


    sPath = "d:\temp2\"


     '    Retrieve the current doc files in directory

    sFile = Dir(sPath & "*.doc")

    Do While sFile <> ""

        strFileNames = strFileNames & "," & sFile

        sFile = Dir()

     Loop


     '  Open each file found

    For Each itm In Split(strFileNames, ",")

        If itm <> "" Then

            Set Wb = Documents.Open(sPath & itm)

            Call addredheader 'this runs my macro from above

            Wb.Close True

        End If

    Next itm


End Sub

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

جرب علي ملفات خالية

حدد مسار الملفات التى تريد التطبيق عليها

ثم شغل الماكرو ProcessAll

سيقوم بتطبيق الماكرو addredheader على كافة الملفات من نوع *.doc داخل المجلد المحدد داخل الكود

وهو هنا فى المثال d:\temp2 كما هو مبين أعلاه

و طبعا ستستبدل الماكرو addredheader بالماكرو الذي تريد تطبيقه

و أخيرا لا تجرب على الملفات الحقيقية

فقط ضع اي ملفات فى المسار d:\temp2 للتجربة ، أو عدل المسار كما تريد

run multi macro.rar

[محمد يحياوي]

ما شاء الله استاذي محمد عمل رائع

[المستشار22]

اخي المهندس / محمد

اشكرك جزيل الشكر على هذا العمل الرائع ..

لكن لم اعرف كيف اتصرف مع هذا الماكرو لان معلوماتي بالماكرو قليلة

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

الى اكبر في جميع المستندات

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

وقد ارفقت لك ملف من هذه الملفات الكثير للتطبيق عليه .. وكذالك ارفقت الماكرو الذي لدي للتطبيق

مهل استطيع ان اضيف اكثر من ملف واكثر من مسار

وفقك الله لكل خير وتقبل الله منا ومنك الصيام والقيام وصالح الاعمال

أبو أكرم.rar

سلوك أول.doc

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

قمت باضافة الكود الى ملف الأخ ابو اكرم

كما قمت بعمل تعديل فى كوده لتثبيت مسار ملف قاعدة البيانات الى

d:\temp2\Replacements.mdb

حتى ال يسأل عنها فى كل ملف

و الآن قم بما يلي

أعد تسمية قاعدة البيانات باسمReplacements و ضعها فى نفس المسار مع الملفات التي تريد التجربة عليها

أي d:\temp2

و شغل الكود

ProcessAll

فى الملف المرفق كما هو

Replace.rar

[المستشار22]

قمت باضافة الكود الى ملف الأخ ابو اكرم

كما قمت بعمل تعديل فى كوده لتثبيت مسار ملف قاعدة البيانات الى

d:\temp2\Replacements.mdb

حتى ال يسأل عنها فى كل ملف

ــــــــــــــــــــــــــ

ـــــــــــــــــــــــــ

اخي محمد : اين الكود؟؟

لم تضع الكود بعد التعديل عليه في المرفقات

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

جر ب مرة أخري

أضفت لك الماكرو أعلى الملف بنفس طريفة أبو أكرم

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

ملاحظة : لقد جربت هذا الملف و عمل معي على جميع الملفات فى المجلد

[المستشار22]

اسأل الله العلي القدير في هذا اليوم يوم الجمعة المباركة ان يبارك لك في علمك وفي عمرك وفي مالك وفي اهلك

وان ييسر لك كل عسير ... واسأله عزوجل ان يوفقك للخير في الدارين ...وان يجعلنا واياك في هذا الشهر من المقبولين

وان يغفر لي ولك ولكل مسلم

اللهم صل وسلم على نبينا محمد وعلى اله وصحبه اجمعين

الان اشتغل تمام

لكن لدي ثلاثة اسئلة :

1ـ يظهر في اخر كل صفحة من المستندات التي اجريت عليها تعديل كلمة ((pAGE )) لااعرف مالسبب؟

2 _ هل استطيع ان اضع اي قاعدة بيانات اخرى في الملف d:\temp2 واضع لها نفس الاسم؟

3 ـ اريد ان اضع اكثر من مسار مثلا اريد ان اضع مع d:\temp2 اضيف d:\temp3 واضيف d:\temp4 وهكذا فماهي الطريقة؟؟

تم تعديل أغسطس 28, 2009 بواسطه المستشار22

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

يظهر في اخر كل صفحة من المستندات التي اجريت عليها تعديل كلمة ((pAGE )) لااعرف مالسبب؟

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

هل تظهر لديك فى الملفات التي ارفقتها سابقا للتطبيق عليها، فهي لا تظهر لدي فيها؟

2

_ هل استطيع ان اضع اي قاعدة بيانات اخرى في الملف d:\temp2 واضع لها نفس الاسم؟

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

3 ـ اريد ان اضع اكثر من مسار مثلا اريد ان اضع مع d:\temp2 اضيف d:\temp3 واضيف d:\temp4 وهكذا فماهي الطريقة؟؟

أتصور أنه يمكن تطويره أيضا ليمكنك من اختيار المسار مع كل تشغيل من خلال شاشةاختيار

اما اضافة أكثر من مسار فى نفس التطبيق فهذا ممكن و لكن سيتطلب اضافة المسارات ضمن الكود و تعديل الكود فى كل مرة تريد تغيير المسارات فيها ، و يبدو لي الحل الاول أفضل

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

السلام عليكم

مرفق الملف و الكود و شرح خطواته

ReplaceallInFolder.rar

و يمكنك حذف الثلاثة أسطر الخاصة بكل رسالة اذا لم ترد ظهورها

و هي التي تبدأ ب msgbox

Sub ProcessAll()

' هذا الكود يقوم باختيار فاعدة البيانات التي تحوي كافة اكلمات المراد استبدالها

' ثم اختيار مسار المجلد الموجود به الملفات المطلوب استبدال الكلمات بها

' ثم استدعاء كود الاستبدال ليعمل عليها واحدا تلو الآخر


Dim Wb As Document, sFile As String, sPath As String

Dim itm As Variant

Dim strFileNames, mydbpath As String

Dim f As FileDialog


' اختيار قاعدة البيانات

Set f = Application.FileDialog(msoFileDialogFilePicker)

f.Show

If f.SelectedItems(1) = "" Then

 MsgBox "يجب اختيار ملف الاكسيس الذي يحوى الكلمات المطلوب استبدالها "

 Exit Sub

End If

mydbpath = f.SelectedItems(1)

 MsgBox "سيتم الاستبدال بناء على الملفت الموجودة فى قاعدة البيانات التالية :  " & _

 Chr(10) & Chr(13) & mydbpath & Chr(10) & Chr(13) & _

 " مع تحيات أوفيسنا  " & Chr(10) & Chr(13) & "www.officena.net"



' اختيار مسار الملفات المطلوب التطبيق عليها

Set f = Application.FileDialog(msoFileDialogFolderPicker)

f.Show

If f.SelectedItems(1) = "" Then

 MsgBox "يجب اختيار مسار المجلد الموجود به الملفات التي تريد التطبيق عليها "

 Exit Sub

End If

sPath = f.SelectedItems(1) & "\"


 MsgBox "سيتم الاستبدال لطافة ملفات الوورد فى المسار التالي :  " & _

 Chr(10) & Chr(13) & sPath & Chr(10) & Chr(13) & _

 " مع تحيات أوفيسنا  " & Chr(10) & Chr(13) & "www.officena.net"


'    اختيار مستندات الوورد فقط ضمن الملفات الموجودة فى المجلد

sFile = Dir(sPath & "*.doc")


' ثم استدعاء كود الاستبدال ليعمل عليها واحدا تلو الآخر

Do While sFile <> ""

strFileNames = strFileNames & "," & sFile

sFile = Dir()

Loop


'  فتح الملفات و تشغيل كود الاستبدال عليها و احدا تلو الاخر

For Each itm In Split(strFileNames, ",")

If itm <> "" Then

Set Wb = Documents.Open(sPath & itm)

Call Replacedoc(mydbpath)  'استدعاء كود الاستبدال

Wb.Close True

End If

Next itm


End Sub



[/sql]

[sql]

Sub Replacedoc(mydbpath As String)
' هذا الكود يقوم باستبدال كافة الكلمات فى الملف المفتوح طبقا لما ورد فى قاعدة البيانات المحدد اسمها و مسارها فى المتغير

Dim doc As Document
Dim db As DAO.Database
Dim rs As Recordset

Set doc = Application.ActiveDocument
Set db = OpenDatabase(mydbpath)
Set rs = db.OpenRecordset(Name:="Table1")
While Not rs.EOF
With doc.Content.Find
.ClearFormatting
.Text = rs(0)
With .Replacement
.ClearFormatting
.Text = rs(1)
End With
.Execute Replace:=wdReplaceAll, _
Format:=True, MatchCase:=True, _
MatchWholeWord:=True
End With
rs.MoveNext
Wend
rs.Close
db.Close
End Sub

ReplaceallInFolder.rar

[المستشار22]

زادك الله علما في امور دينك ودنياك ....وسعادة ...وتوفيقا ...

فلقد اكثرت عليك الاسئلة فلم اجد منك الا سعة الصدر ...وحسن المعاملة

فلقد كنت مثالا في الصبر على المتعلم

بارك الله فيك وفي جهودك في مساعدة اخوانك

واعتذر عن التأخر في الرد بسبب انقطاع الاتصال