نجوم المشاركات

السلام عليكم ورحمة الله وبركاته أثرت فضولنا...دعنا نرى ...إذاً. توكل على الله

من منا لم يحلم أن يكون له تطبيق خاص في الموبايل مصمم عن طريق الإكسيل، ومتوافق مع جميع الأجهزة، لإثراء الموضوع ومعرفة المهتمين في الموضوع، حمسونا بآرائكم علشان أنزل لكم بعض الطرق البسيطة المجربة لدي.

فكرة البرنامج: عمل برنامج اكسيل يستوعب الكثير من البيانات باقل مساحه وبدون عناء فى استخدام الصيغ والمعادلات او الاكواد فى VBA وفى نفس الوقت يعرض العديد من التقارير . وهذا النموذج من البرنامج مجرد فكره ويمكن اعداد برامج شبيه له كما يناسب احتياجك . لاتنسونا بصالح دعاؤكم تحميل وشرح البرنامج http://excelfinancial1.blogspot.com.eg/2016/04/dashbord-sales.html تحميل ملف التطبيق sales.rar

السلام عليكم الاستعلام في وضع التصميم: ومهم جدا لنجاح هذه العملية ان يكون الاستعلام 1. بفرز مواد المجموعات ، ثم 2. بفرز الترقيم التلقائي مثلا ، وعمل الترقيم تقوم به الوحدة النمطية RowCounter : . والنتيجة: . ولتحديث الجدول Items ، يجب ان يكون لدينا الاستعلام اعلاه ، ثم يقوم الاستعلام qry_2_Update بتحديث الجدول على اساسه وهذه هي الوحدة النمطية: Option Compare Database Option Explicit Public Function RowCounter( _ ByVal strKey As String, _ ByVal booReset As Boolean, _ Optional ByVal strGroupKey As String) _ As Long ' Builds consecutive RowIDs in select, append or create query ' with the possibility of automatic reset. ' Optionally a grouping key can be passed to reset the row count ' for every group key. ' ' Usage (typical select query): ' SELECT RowCounter(CStr([ID]),False) AS RowID, * ' FROM tblSomeTable ' WHERE (RowCounter(CStr([ID]),False) <> RowCounter("",True)); ' ' Usage (with group key): ' SELECT RowCounter(CStr([ID]),False,CStr([GroupID])) AS RowID, * ' FROM tblSomeTable ' WHERE (RowCounter(CStr([ID]),False) <> RowCounter("",True)); ' ' The Where statement resets the counter when the query is run ' and is needed for browsing a select query. ' ' Usage (typical append query, manual reset): ' 1. Reset counter manually: ' Call RowCounter(vbNullString, False) ' 2. Run query: ' INSERT INTO tblTemp ( RowID ) ' SELECT RowCounter(CStr([ID]),False) AS RowID, * ' FROM tblSomeTable; ' ' Usage (typical append query, automatic reset): ' INSERT INTO tblTemp ( RowID ) ' SELECT RowCounter(CStr([ID]),False) AS RowID, * ' FROM tblSomeTable ' WHERE (RowCounter("",True)=0); ' ' 2002-04-13. Cactus Data ApS. CPH ' 2002-09-09. Str() sometimes fails. Replaced with CStr(). ' 2005-10-21. Str(col.Count + 1) reduced to col.Count + 1. ' 2008-02-27. Optional group parameter added. ' 2010-08-04. Corrected that group key missed first row in group. Static col As New Collection Static strGroup As String On Error GoTo Err_RowCounter If booReset = True Then Set col = Nothing ElseIf strGroup <> strGroupKey Then Set col = Nothing strGroup = strGroupKey col.Add 1, strKey Else col.Add col.Count + 1, strKey End If RowCounter = col(strKey) Exit_RowCounter: Exit Function Err_RowCounter: Select Case Err Case 457 ' Key is present. Resume Next Case Else ' Some other error. Resume Exit_RowCounter End Select End Function Public Function Reset_RowCounter() Call RowCounter(vbNullString, False) End Function Public Function Correct_Last_Sequence() Dim rst As DAO.Recordset Dim Last_Seq As Integer Set rst = CurrentDb.OpenRecordset("Select * From 1 Order By Auto_ID Desc") rst.MoveNext Last_Seq = rst!M rst.MovePrevious rst.Edit rst!M = Last_Seq + 1 rst.Update rst.Close: Set rst = Nothing End Function جعفر 361.Database1.mdb.zip

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

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

الحمد لله الذي بنعمته تتم الصالحات أخي الحبيب وائل شعبان لقد استغرق مني العمل أيام .. بالبحث في المنتديات المختلفة والمواقع المختلفة ، والإضافة والتعديل للوضول لأفضل نتيجة ممكنة في الملف المرفق ستجد 3 أكواد .. الكود الأول المسمى Delete_Blanks_Basmla يقوم بحذف الصفوف التي تحتوي على البسملة عدا البسملة في الفاتحة والصفوف الفارغة والصفوف التي تحتوي أسماء السور ثم يأتي الكود الثاني (وسيستغرق في التنفيذ حوالي 5 دقائق لكيلا تقلق .. حاولت أن أجعله ينفذ بشكل أسرع ولكن يبدو أن البيانات ضخمة وعمليات المعالجة تحتاج لوقت ، ولكن لا أعتقد أن هذا سيسبب مشكلة حيث سيتم التنفيذ لمرة واحدة فقط .. للحصول على النتائج المطلوبة بعدها يمكنك نسح النتائج ووضعها في ملفك أو في أي ورقة عمل أخرى حسبما تريد) والكود المسئول على عمليات المعالجة للبيانات للحصول على المطلوب يسمى Main_Proc ثم يأتي في النهاية كود خفيف يقوم بوضع أسماء السور مقابل كل آية من الآيات في العمود الثاني وهو الكود SuratNames .. لتنفيذ الكود يمكنك الضغط على Alt + F8 ثم اختيار اسم الإجراء الفرعي المطلوب تنفيذه .. يراعى ترتيب التنفيذ (الكود الأول فالثاني فالثالث .. للحصول على نتائج منضبطة بإذن الله) أسأل الله العظيم أن يغفر لنا بهذا العمل وأن يجعله في ميزان حسناتنا يوم القيامة وأخيراً إليك الملف المرفق فيه ما ذكرت ، ولا تنسونا من صالح دعائكم .. لكي يظهر الملف بالخط المستخدم ، يرجى تنصيب الخط في المرفقات (فك الضغط عن الملف ثم كليك يمين ثم Install) حمل الملف من هنا UthmanicHafs1 Ver09.rar

أخي الكريم أحمد حمل الملف من هنا أرجو أن يكون المطلوب إن شاء الله تقبل تحياتي

....................................waiting

التخطيط للبرنامج: طبعاً ببساطة صفحة الإدخال تحتوي على خانة الاستعلام عن الرقم ، والمخرجات هي بيانات الكتاب كالتالي: أولاً:صفحة الإدخال ثانيا: المخرجات: ومن الممكن دمجها في صفحة واحدة انتظرونا في طريقة العمل

بارك الله فيك و لك مقدّمًا و مؤخّرًا جزاك الله خير الجزاء و زادك من علمه و فضله

بوركت سؤال آخر لماذا نكتب قبل المعادلة rds او mrd وماذا تعني ؟

نشكر الجميع على التفاعل البناء، وأخص بالشكر إلى أبويوسف على التسويق للفكرة آمل أن تنال على إعجابكم في البداية خلونا نجهز ملف إكسيل للإستعلام عن البيانات عن طريق دالة vloockup أو ما يعادلها، ومن ثم نطور الفكرة.. (جهزوا ملفاتكم ) أنا جهزت الملف التالي: sejel01.rar

تفضل نفس موضوعك ، بالمجموعات: http://www.officena.net/ib/topic/60480-طباعة-اصناف-محددة-معينة-بالنموذج-الفرعي-وليس-كل-الاصناف/ والنتيجة (لاحظ لون الرقم المسلسل يتماشى مع نوع الطبق): . وهنا التسلسل للسجلات: http://www.officena.net/ib/topic/63356-ترقيم-سجل-بعد-البحث/?do=findComment&comment=412591 جعفر

السلام عليكم الأخ الجليل ياسر خليل المعلم القدير ياسر خليل دائما ودوما نجد حيث نحتاج اليك عمل مبهر ... كما عهدناك دوما جزاك الله خيرا

وجزيت خيراً أخي الحبيب سعد عابد مشكور على مرورك العطر بالموضوع ..وعلى كلماتك الطيبة حاول تطرح موضوع جديد وترفق ملف بشكل المطلوب وإن شاء الله أنا والأخوة بالمنتدى كل واحد يساهم في حل الموضوع بأسلوب علمي يتكاتف فيه الجميع تقبل تحياتي

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

زادك الله حرصا على الخير أبا البراء المسألة وما فيها أن الـ IT في الشغل عملين لوك لكثير من المواقع والتحميلات عموما انا لسة واصل البيت وحملت الملف خمسة وأوافيك بالنتائج أكرر شكرى لك على حرصك على التسهيل والمساعدة

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

أخي وحبيبي في الله محمد الريفي موضوعاتك قمة في التميز والحصرية والروعة .. بارك الله فيك وجزاك الله كل خير على هذه الموضوعات القيمة تقبل وافر تقديري واحترامي

أخي الحبيب الزباري شوقتنا للمفاجأة السارة ... في انتظار جديدك يا كبير تقبل تحياتي

توكل على الله كلنا بالانتظار فى شغف

على أحر من الجمر......

أخي الحبيب محمد الريفي أبو أحمد السلام عليكم...ريادة في الأعمال الرائدة..أي في مقدمة المقدمة مبدعي الإكسيل .. جزاكم الله خيرا..تقبل تحياتي..والسلام عليكم.

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

....................................I 'm waiting

جزاك الله خيرا بالأنتظار

السلام عليكم ورحمة الله تحياتى لابداعاتك المتواصلة اعز الله اجرك

جزاك الله خير بانتظارك

يرجى صورة توضيحية للمشكلة للتوضيح اكثر هل جربتي الاصلاح بهذه الاداة؟؟ MicrosoftFixit50274.rar

شيئ جميل وجزاك الله خيرا في انتظار المرفق

تفضل اخي الكريم لعله المطلوب اختر البحث بمعلومية الB or C Match.rar

الحب في الله تعالى أوثق عرى الإيمان وهو منحة من الله لا يشترى بالمال . قال تعالى في بيان فضله على عباده المتحابين ( وَأَلَّفَ بَيْنَ قُلُوبِهِمْ لَوْ أَنفَقْتَ مَا فِي الأَرْضِ جَمِيعًا مَّا أَلَّفَتْ بَيْنَ قُلُوبِهِمْ وَلَكِنَّ اللهَ أَلَّفَ بَيْنَهُمْ إِنَّهُ عَزِيزٌ حَكِيمٌ ) . و قد جعل الله الحب في الله سببا للنجاة من النار و دخول الجنة ، ففي الحديث الصحيح المتفق عليه في السبعة الذين يظلهم الله تحت ظله ، منهم ( رجلان تحابا في الله ، اجتمعا عليه ، و تفرقا عليه ) المحبة في الله نعمة من الله ، فقد الأحبة في الله غربة ، والتواصل معهم أنس ومسرة ، هم للعين قرة ، فسلام على من دام في القلب ذكراهم ، وإن غابوا عن العين قلنا يا رب احفظهم وارعاهم . لا يوجد متسع للكلام ، أحبكم في الله جمعياً اخي في الله المبدع أ/ شوقي ربيع وثمرة التعاون المثمر بأذن الله بيننا ، نأتي من جديد في سلسة برامج ضاحي وشوقي الخدمية ، لتيسير ما امكن علي اخواننا , نفعنا الله واياكم بما علمنا ولا تنسونا بدعوة بصلاح الحال بظهر الغيب . كلمة مرور الأدمن admin VBA Password 6626 فورم تعديل / اضافة صلاحيات المستخدمين البرنامج بالمرفقات Multi User Form Permissions Management.rar

العضو الكريم fafa5000 اولا مرحبا بك في منتدى اوفيسنا ثانيا يرجى قراءة توجيهات المنتدى جيدا كمل يرجي تغيير اسم الظهور الخاص بك للغة العربية لسهولة التعامل تفضل كلمة المرور اسم المستخدم admin كلمة المرور admin VBA Password 6626

تفضل اظهار السعر تلقائيا بعد اختيار 11اسم المادة.rar

السلام عليكم مرحبا بكِ اختنا الكريمة ام روان في بيتك الثاني واسرتك الثانية اوفيسنا تحياتي

سلام الله على الجميع يبدو أن نومى باكرا بالأمس قد ضيع منى فرصة أن أكون أول مهنئ على اكتمال العمل بفضل الله فالحمد الله إبتداء وأنتهاء. الأخوة الكرام ياسر خليل (أبو البراء) أبا عيد اخواكم في الله الكلمات لا توفيكم حقكم نسأل الله أن يتقبل منا دعائنا لكم وأن يحفظكم ويبارك فيكم شكر الله لكم. لعدم استطاعتى عمل دولون لود إلا للخط فقط دون الملف الأساسي بعد انتهاء وقت العمل سأوافيكم بالنتيجة. وحرصا على أن أسهم لى بنصيب في ثواب وخدمة هذا العمل الطيب المبارك بإذن الله لخدمة كتاب الله وتسهيلا وتيسيرا للباحثين وطلبة العلم الشرعى سيكون لى بإذن الله تعالى إسهام بسيط في تطعيم هذا العمل بالمزيد من البيانات الهامة بما تيسر لى جمعه بعد أن يأخذ الملف شكله النهائى ليكون مرجعا في مكتبة المنتدى لينتفع به كل مسلم يريد الحق على هدى سلف الأمة كما أقترح ذلك الأخ الفاضل أبا عيد. الأخوة الإعزاء نرجوا ألا تحرمونا من تفاعلكم الجاد والمخلص والمثمر هذا عند طرح موضوعات أخرى يظهر لنا الحاجة فيها إلى علمكم وخبرتكم. جزا الله القائمين على امر هذا المنتدى النافع كل خير وتقبل الله من الجميع حسن تفاعلهم وجمعنا دائما على ما يحب ويرضى شكرا لكم والسلام.

اخى الكريم تفضل الحل على حسب ما فهمت من طلبك شاهد المرفق واى تعديل انا تحت امرك وانصحك لو عايز تتعلم راجع الرابط التالى تقبل تحياتى Book1.zip

السلام عليكم نحن نحتاج (SQL Management Studio) للتاكد من اتصال (clinet) بالسيرفر وكذلك الى تغيير الرقم السري للدخول الى حساب المستخدمين برقم جديد --- فاذا تاكد الاتصال اثناء عمليه الربط بين ال (clinet) والسيرفر بعدم وجود (SQL Management Studio) وتمكنت من الدخول الى الحساب المستخدم بالرقم القديم فلا حاجه (SQL Management Studio) وسوف نجرب هذه الحاله باقرب وقت ونوافيكم بالنتيجه ان شاء الله بالتوفيق

الأخوة الأعزاء أعضاء المنتدى الكرام أشكر لكم الردود وأسأل الله أن ينفعكم بعلمه ويجعله لكم مثقالا يوم القيامة في ميزان حسناتكم أما الأخ كرار صبري _ أبو جنى فلك كل الاحترام والتقدير وكلام أستاذي ابوخليل له مني كل الاحترام والتقدير أما ما شعرت به من استصغار لسؤالي فليس نابعا من رد واحد وإنما من تتبع الردود على الموضوعات يوميا منذ 15 يوليو 2013 فمن طبعي أن أظل قابعا منصتا في الفصل حتى أكون فكرة جيدة عن المعلم واحسب أن الفترة التي قضيتها معكم كفيلة بذلك . ونظرا لأنني أؤمن بقول الشاعر : وقل من جد في أمر يحاوله واستصحب الصبر إلا فاز بالظفر . فقد عملت على فكرتي بما لدي من معلومات متواضعة مقارنة بأساتذة المنتدى الكرام وتوصلت لما أبتغيه وأخيرا قد يكون الخطأ مني وليس منكم فلكم كل الشكر وجزاكم الله خيرا .

غير فقط النطاق المسمى sRng الى النطاق (" Range("H3:NV202

سيدى الفاضل / محمد حسن المحمد وعليكم السلام ورحمته الله وبركاته كلمات وضائة ملؤها الامل والعمل بارك الله فى حضرتك تقبل وافر تقديرى ابو البراء ههههههههه مش زنقه ولا حاجة هية زنجة زنجة وحارة حارة

أين التفاعل أم روان ..؟؟ ننتظر منك هدية للمنتدى بمناسبة انضمامك ... أول زنقة !!

أخي الكريم أحمد أعتقد أنك تحتاج لتنصيب NetFroamwork 3.5 >> لأن هذه المشكلة حدثت معي من فترة مع هذه المكتبة .. ما هو الويندوز الذي تستخدمه ؟

مرحبا بك فى منتدانا

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

السلام عليكم ورحمة الله وبركاته إخواني الكرام في منتدى أوفيسنا رغم قلة التفاعل في الموضوعات التي تقدم ، ولا أقصد بالتفاعل الردود العادية ، إنما أقصد المشاركة بالبحث والنقد والتفنيد والتفحيص والتدقيق والتمحيص والإضافة ...رغم قلة التفاعل أقدم كل يوم موضوع جديد لعل وعسى أن يأتي أناس من بعدنا ليستفيدوا مما نقدم ويكون المنتدى لهم نبراساً يستنيرون به في هذا المجال أقدم لكم موضوع حول إدراج أسماء الشهور بكل اللغات .. إليكم الكود التالي ، قم بوضع الكود في موديول عادي ... ثم نفذ الكود ولاحظ النتائج بنفسك Sub ListMonthsInAllLanguages() 'يقوم الكود بإدراج أسماء شهور السنة بكل اللغات '--------------------------------------------- Dim R As Long, C As Long Dim strDate As Date Dim S, bFind As Boolean Application.ScreenUpdating = False For R = 1 To 12 For C = 1 To 99 strDate = CDate("01/" & Format(R, "00") & "/2015") S = "[$-4" & Format(C, "00") & "]MMMM" Cells(R, C).NumberFormat = S Cells(R, C).Value = strDate Next C Next R Columns.AutoFit Application.ScreenUpdating = True End Sub أرجو أن ينال الملف والموضوع إعجابكم وتستفيدوا منه إن شاء الله حمل الملف من هنا تقبلوا تحياتي كان معكم أخوكم أبو البراء

أخي الحبيب صلاح أنا بقالي يومين بحاول أشوف الموضوع فين .. يظهر العفاريت عملوها فينا وأخفوا الموضوع عموماً كنت قد طلبت الطريقة ووجب علي أن أقدمها لك خصوصاً بعد انتظار أسبوع الموضوع والحل الذي لدي في قمة البساطة والسهولة .. وأنا خايف تشتم بعد ما تعرف الطريقة (فعايز وعد منك من غير شتيمة) الحل بدون أكواد على الإطلاق المصنف اللي فيه الصور المراد استخراجها غير امتداده من xlsm إلى zip .. وروح اعمل كليك يمين عليه واعمل Extract أي استخراج للملفات .. هيطلع لك من ضمن المستخرج مجلد اسمه Media ودا جواه الصور بنفس التنسيق ونفس الحجم تماماً وسلم لي على التروماي .. ومش عاااااااااااااايز شتيمة تقبل وافر تقديري واحترامي

الأستاذ / محمد عبارة السلام عليكم ورحمة الله وبركاته هذه الدالة مثل دالة الجمع التلقائي ولكن تستخدم عند التصفية أو الفرز لأنها لا تجمع القيم المخفية الناتجة من الفرز أو التصفية وبالنسبة لرقم 9 هذا رقم الجمع العادي وإذا اخترت بدل من 9 بـ 1مثلاً رقم 1 يعبر عن ايجاد المتوسط ورقم 2 ، 3 يستخدم لعد الخلايا ورقم 4 يستخدم لإيجاد أكبر قيمة ورقم 5 لأيجاد أصغر قيمة وهذا كله بعد التصفية أو الفرز .أرجو أن أكون وضحت بعض استخدامات هذه الدالة على حد علمي والله اعلم. وإليك الملف بعد استخدام هذه الدالة في الترقيم التلقائي. Book3.rar

السلام عليكم الاخ الكريم / الصّارم اعتقد ان التالي به طلبك تماماً ولكن عذرا للاطالة فالموضوع ليس موضوعي ولكنه للقدير العبقري الاستاذ القدير / جعفر طرباق .... جزاه الله خيرا بعنوان ((( كيف نجعل الملف ينتحر و يحدف نفسه من الجهاز تلقائيا ! )))) ولكني احببت ان انقله كما هو ليستفيد منه الجميع بكل طرقه واشكاله ============================================= الكود ادناه يفعل ذلك من داحل الملف نفسه و يمكن ربطه مثلا بالحدث Workbook_BeforeClose و مسح الملف تلقائيا و نهائيا و من دون اشعار المستخدم. SuicidalWorkbook.rar Option Explicit Private Const MSG_TITLE As String = "Deleting Current Workbook ..." Private Const MSG_TEXT As String = _ "You are about to permanently delete the current workbook located in :" Sub Kill_Myself() Dim lUserDecision As Long Dim sMsg As String On Error Resume Next sMsg = "Attention !" & vbNewLine & vbNewLine sMsg = sMsg & MSG_TEXT & vbNewLine sMsg = sMsg & "'" & ThisWorkbook.FullName & "'" & vbNewLine sMsg = sMsg & "from Disk!!" & vbNewLine & vbNewLine sMsg = sMsg & "Go ahead ?" & vbNewLine & vbNewLine Beep lUserDecision = _ MsgBox(sMsg, vbExclamation + vbYesNo, MSG_TITLE) With ThisWorkbook If lUserDecision = vbYes Then .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End If End With End Sub ====================================================== الكود التالي يحدف الملف بعد شهر واحد من اول استعماله تلقائيا و بدون اشعار المستخدم ! ضع الكود في ThisWorkbook Module Option Explicit Private Sub Workbook_Open() Dim lInitialDate As Long On Error Resume Next lInitialDate = Evaluate("InitialDate") If Err.Number = 13 Then Me.Names.Add "InitialDate", Date, False Me.Save End If If Date > Evaluate("InitialDate") + 30 Then Kill_Myself End Sub Private Sub Kill_Myself() .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End Sub ينصح اقفال الكود بباسوورد لمنع المستخدم من رؤية او حدف الكود. ================================================================ الكود التالي يحدف الملف بعد 3 الستعمالات تلقائيا و بدون اشعار المستخدم ! ضع الكود في ThisWorkbook Module Option Explicit Private Const MAX_USES As Long = 3 Private Sub Workbook_Open() Dim lNumberOfUses As Long On Error Resume Next lNumberOfUses = Evaluate("NumberOfUses") If Err.Number = 13 Then Me.Names.Add "NumberOfUses", 1, False Me.Save Exit Sub End If Me.Names.Add "NumberOfUses", Evaluate("NumberOfUses") + 1, False Me.Save If Evaluate("NumberOfUses") > MAX_USES Then Kill_Myself End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub ينصح اقفال الكود بباسوورد لمنع المستخدم من رؤية او حدف الكود ========================================================= الكود التالي يحذف الملف بعد دقيقة واحدة من فتحه : (ضع الكود في ThisWorkbook Module) Option Explicit Private Const TIMEOUT As Long = 1 Private Sub Workbook_Open() Application.OnTime _ Now + TimeSerial(0, TIMEOUT, 0), Me.CodeName & ".Kill_Myself" End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub ===================================================== حذف الملف ولكن باشعار المستخدم بذلك !!!! للتمكن من اشعار المستخدم و في نفس الوقت منعه تماما من اجهاض عملية حذف الملف , اقترح الكود التالي حيث يتم اشعار المستخدم بعد حذف الملف و ليس قبل : (الملف يحذف نفسه تلقائيا بعد 3 استعمالات و يشعر المستخدم بعد الحذف) Option Explicit Private Const MAX_USES As Long = 3 Private Sub Workbook_Open() Dim lNumberOfUses As Long On Error Resume Next lNumberOfUses = Evaluate("NumberOfUses") If Err.Number = 13 Then Me.Names.Add "NumberOfUses", 1, False Me.Save Exit Sub End If Me.Names.Add "NumberOfUses", Evaluate("NumberOfUses") + 1, False Me.Save If Evaluate("NumberOfUses") > MAX_USES Then Call NotifyUser Call Kill_Myself End If End Sub Private Sub NotifyUser() Dim sVbsFile As String sVbsFile = Environ("Temp") & "\VBS_MSG.vbs" Open sVbsFile For Output As #1 Print #1, "Dim Wb" Print #1, "On Error Resume Next" Print #1, _ "set wb=Getobject(" & Chr(34) & Me.FullName & Chr(34) & ")" Print #1, _ "MSG= ""You have exceeded the Maximum Number of uses of this file."" & vbnewline & vbnewline" Print #1, _ "MSG= msg & ""The file has been permanently deleted from your Drive !""" Print #1, "Do" Print #1, "Loop until wb.name=""""" Print #1, "WScript.Echo MSG" Close #1 Call Shell("WScript.exe " & sVbsFile) End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub وارجو من الله ان يجعل فيها افادة ... وادعو للاستاذ القدير العملاق / جعفر ... جزاه الله خيرا جزاكم الله خيرا