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

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

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

فكرة البرنامج: عمل برنامج اكسيل يستوعب الكثير من البيانات باقل مساحه وبدون عناء فى استخدام الصيغ والمعادلات او الاكواد فى 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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

جزاكم الله خيرا تحياتى و مزيد من الروائع

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

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

هل تريد عدم تكرار البيانات عد الى الموديل ستجد الجملة : ( 1 + ) مكررة 6 مرات قم بمسحها Dim Sh_LFP As Worksheet Dim Sh_LTR As Worksheet Dim Sh_LHL As Worksheet Dim Sh_IPD As Worksheet Sub Copy1() Application.ScreenUpdating = False Dim R_LFP As Long, LastR_LFP As Long Dim R_IPD As Long, LastR_IPD As Long Set Sh_LFP = Sheets("LFP") Set Sh_IPD = Sheets("IPD") LastR_IPD = Sh_IPD.Cells(Rows.Count, "J").End(xlUp).Row LastR_LFP = Sh_LFP.Cells(Rows.Count, "J").End(xlUp).Row For R_LFP = 2 To LastR_LFP Sh_LFP.Range("J" & R_LFP).Resize(1, 10).Copy Sh_IPD.Range("J" & LastR_IPD).PasteSpecial xlPasteValues LastR_IPD = LastR_IPD + 1 If R_LFP = LastR_LFP Then Copy2 Next End Sub Sub Copy2() Dim R_LTR As Long, LastR_LTR As Long Dim R_IPD As Long, LastR_IPD As Long Set Sh_LTR = Sheets("LTR") Set Sh_IPD = Sheets("IPD") LastR_IPD = Sh_IPD.Cells(Rows.Count, "T").End(xlUp).Row LastR_LTR = Sh_LTR.Cells(Rows.Count, "T").End(xlUp).Row For R_LTR = 2 To LastR_LTR Sh_LTR.Range("T" & R_LTR).Resize(1, 9).Copy Sh_IPD.Range("T" & LastR_IPD).PasteSpecial xlPasteValues LastR_IPD = LastR_IPD + 1 If R_LTR = LastR_LTR Then Copy3 Next End Sub Sub Copy3() Dim R_LHL As Long, LastR_LHL As Long Dim R_IPD As Long, LastR_IPD As Long Set Sh_LHL = Sheets("LHL") Set Sh_IPD = Sheets("IPD") LastR_IPD = Sh_IPD.Cells(Rows.Count, "AC").End(xlUp).Row LastR_LHL = Sh_LHL.Cells(Rows.Count, "AC").End(xlUp).Row For R_LHL = 2 To LastR_LHL Sh_LHL.Range("AC" & R_LHL).Resize(1, 9).Copy Sh_IPD.Range("AC" & LastR_IPD).PasteSpecial xlPasteValues LastR_IPD = LastR_IPD + 1 Next Application.ScreenUpdating = False End Sub

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

السلام عليكم هذا بالنسبة للترحيل فقط osamahreport2.rar

جزاك الله خيرا

اختى الكريمة تأكدي من اختيارك لاسم الطابعة كما بالصورة مع اختلاف اسم الطابعة فقط

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

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

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

اخي الفاضل استبدل التكست بوكس4 بالكمبوبوكس1 تكتب هكذا مكان الجزء المشار له بالازرق في الصورة Me.ComboBox1.Value وفي السطر قبل الاخير ايضا Me.ComboBox1.Value = "" السبب مفيش في الفورم حاجه اسمها TxtBox4 والبديل لها ComboBox1

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

اخى الفاضل شكرا جدا جدا جدا على المجهود الرائع هذا هو المطلوب اشكرك

أخي الكريم لم تحدد عدد الأرقام العشوائية المطلوبة التي توصلك للهدف المنشود ؟ عموماً جرب الملف التالي .. يمكنك سحب المعادلات إلى حيثما شئت وستجد أن مجموع الأرقام العشوائية المولدة في العمود الثاني يساوي 5000 كما طلبت في المرفق حمل الملف من هنا

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

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

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

ها هو الملف Book11.rar

تفضل ... mathtest2.rar

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

جزيت خير وبارك الله فيك.

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

بارك الله فيك عمل رائع

السلام عليكم ورحمة الله وبركاته إخواني الكرام في منتدى أوفيسنا رغم قلة التفاعل في الموضوعات التي تقدم ، ولا أقصد بالتفاعل الردود العادية ، إنما أقصد المشاركة بالبحث والنقد والتفنيد والتفحيص والتدقيق والتمحيص والإضافة ...رغم قلة التفاعل أقدم كل يوم موضوع جديد لعل وعسى أن يأتي أناس من بعدنا ليستفيدوا مما نقدم ويكون المنتدى لهم نبراساً يستنيرون به في هذا المجال أقدم لكم موضوع حول إدراج أسماء الشهور بكل اللغات .. إليكم الكود التالي ، قم بوضع الكود في موديول عادي ... ثم نفذ الكود ولاحظ النتائج بنفسك 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 ودا جواه الصور بنفس التنسيق ونفس الحجم تماماً وسلم لي على التروماي .. ومش عاااااااااااااايز شتيمة تقبل وافر تقديري واحترامي

السلام عليكم ... يتألف مستند الوورد من section واحد أو أكثر ... (section = جزء) , بشكل افتراضي لدينا section واحد يمثل كامل المستند . بعض التأثيرات (مثل اتجاه الصفحة) تطبق على الــ section .. بمعنى أنك لو حاولت تغيير اتجاه صفحة في مستند ستجد أن الصفحات التالية لها قد تغيير اتجاهها أيضا !!!! الحل هو إنشاء section يحوي تلك الصفحة و تغير اتجاه الصفحة ... ضع المشيرة في الصفحة السابقة للصفحة المطلوب تغيير اتجاهها ثم من التبويب page layout اختر breaks ثم next page .. ضع المشيرة في الصفحة المطلوبة ثم من التبويب page layout اختر breaks ثم next page ... هكذا اصبح لدينا section مكون من صفحة واحدة ضع المشيرة في الصفحة المطلوبة ثم من التبويب page layout اختر orientation ثم Landscape ... الفيديو التالي (هو بدون صوت) يوضح الخطوات المذكورة : https://www.youtube.com/watch?v=PEgNmZOntK4

الأستاذ / محمد عبارة السلام عليكم ورحمة الله وبركاته هذه الدالة مثل دالة الجمع التلقائي ولكن تستخدم عند التصفية أو الفرز لأنها لا تجمع القيم المخفية الناتجة من الفرز أو التصفية وبالنسبة لرقم 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 وارجو من الله ان يجعل فيها افادة ... وادعو للاستاذ القدير العملاق / جعفر ... جزاه الله خيرا جزاكم الله خيرا