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

لوم وعتب للاسف برغم ان الموضوع رائع ومفيد جدا الا انه حتى اللحظه شاهده 51 والتعليقات فقط من 2 اعضاء يا خساره يا اعضاء اوفيسنا فين التفاعل؟ فين المشاركات ؟ فين الشكر؟ فين الاهتمام؟ فين الاستفسار عن شئ غامض مثلا بالفيديو ؟ فين النقد حتى لو فرضنا فى شئ غلط؟ فين فين فين لو واحد مننا طلب سؤال وبس مجرد تأخر الاساتذه علينا بالرد بنزعل سبحان الله ولما استاذ قدير ورائع مثل محمد الريفى يقدم موضوع مهم زى ده ويقدمه فيديو وميهتمش بالردود والتفاعل غير 2 فقط والله خساره والف خساره احنا كدا بنخلى اللى عايز يقدم لنا شئ جديد ومفيد يحبط من عدم تفاعلنا واهتمامنا ياريت نراجع انفسنا

السلام عليكم ورحمة الله وبركاته أساتذتى واخوتى اليوم أقدم لكم كودا منقولا بعد تعديله وترجمته لتحديد الفترة التجريبية لملف اكسل . فكرة الكود : عند فتح الملف يتم انشاء ملف نصى دون شعور المستخدم يتم تحرير تاريخ ووقت بداية فتح الملف فى الملف النصى بقورمات معين كما يظهر فى الكود بعد ذلك يقارن اكسل تاريخ اليوم مع التاريخ المحرر فى الملف النصى حتى تنتهى أيام الفترة التجريبية فاذا انتهت الفترة التجريبية يتم الآتى : 1 - اغلاق ملف الاكسل و عدم قدرتك على فتحه 2 - انشاء مجلد جديد تجد فيه : ملف نصى نشكرك فيه على تجربة المنتج وأوراق العمل فى الملف الأصلى تحفظ لك كل على حدة فى ملف مستقل الكود وعليه الشرح : Option Explicit Private Sub Workbook_Open() Dim StartTime#, CurrentTime# '---------------------------------------------------------- ' اعداد الفترة التجريبية كالتالى ' Integers 1, 2, 3,30 ,365 ...etc = number of days use ' 1/24 = 1hour , 1/48 = 30Mins , 1/144 = 10Mins use Const TrialPeriod# = 30 ' 30 days trial '---------------------------------------------------------- 'انشاء ملف مبهم المسار والاسم لتحديد بداية الفترة التجريبية Const ObscurePath = "C:\" Const ObscureFile = "Test File Log.Log" 'اذا كان الملف ذو المسار والاسم المحدد فارغا فان If Dir(ObscurePath & ObscureFile) = Empty Then ' بداية الوقت = تاريخ اليوم والوقت الحالى بالتنسيق الخاص StartTime = Format(Now, "#0.#########0") 'جواب الشرط : افتح الملف ذو المسار والاسم المحدد Open ObscurePath & ObscureFile For Output As #1 'تابع جواب الشرط : اكتب فى الملف بداية الوقت Print #1, StartTime Else ' فى حالة عدم تحقق الشرط فان 'افتح الملف ذو المسار والاسم للتحقق من وقت البداية Open ObscurePath & ObscureFile For Input As #1 Input #1, StartTime ' الوقت الحالى = تاريخ اليوم والوقت الحالى بالتنسيق الخاص CurrentTime = Format(Now, "#0.#########0") 'اذا كان الوقت الحالى أقل من بداية الوقت + الفترة التجريبية If CurrentTime < StartTime + TrialPeriod Then Close #1 ' غلق الملف المبهم قيد الاستعمال Exit Sub ' الخروج من الاجراء Else ' فى حالة عدم تحقق الشرط If [A1] <> "Expired" Then ' اذا كانت الخلية لا تساوى النص "Expired" فان ' رسالة للمستخدم بانتهاء الفترة التجريبية وعدم صلاحية الملف للاستعمال MsgBox "Sorry, your trial period has expired " & vbLf & _ "your data will now be extracted and saved for you..." & vbLf & "" & vbLf & _ "This workbook will then be made unusable." Close #1 ' غلق الملف المبهم قيد الاستعمال SaveShtsAsBook ' استدعاء كود حفظ البيانات للمستخدم [A1] = "Expired" ActiveWorkbook.Save ' حفظ الملف Application.Quit ' اغلاق اكسل نهائيا ElseIf [A1] = "Expired" Then ' اذا كانت الخلية تساوى النص "Expired" فان Close #1 ' غلق الملف المبهم قيد الاستعمال Application.Quit ' اغلاق اكسل نهائيا End If End If End If Close #1 End Sub Sub SaveShtsAsBook() ' كود حفظ بيانات المستخدم بحيث كل شيت يحفظ فى ملف منفصل Dim MyFilePath As String, Sheet As Worksheet, SheetName As String, N As Integer MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) With Application .ScreenUpdating = False ' ايقاف تحديث الشاشة .DisplayAlerts = False ' ايقاف التنبيهات On Error Resume Next ' فى حالة الخطأ تجاهله MkDir MyFilePath ' انشاء مجلد فارغ باسم الملف For N = 1 To Sheets.Count ' حلقة تكرارية بعدد أوراق الملف Sheets(N).Activate ' تنشيط الشيت SheetName = ActiveSheet.Name ' اعتبار المتغير = اسم الشيت Cells.Copy ' نسخ كامل الشيت Workbooks.Add (xlWBATWorksheet) ' انشاء ملف اكسل جديد With ActiveWorkbook ' مع الملف النشط With .ActiveSheet ' مع الشيت النشط .Paste ' لصق البيانات فيه .Name = SheetName ' تسمية الشيت النشط [A1].Select ' تنشيط الخلية End With ' حفظ الملف النشط فى المجلد باسم الشيت النشط .SaveAs FileName:=MyFilePath & "\" & SheetName & ".xls" ' غلق الملف النشط مع حفظ البيانات .Close SaveChanges:=True End With .CutCopyMode = False ' تفريغ الذاكرة العشوائية Next ' الشيت التالى End With ' انشاء ملف نصى به تعليمات هامة للمستخدم بداخل المجلد Open MyFilePath & "\Read Me.log" For Output As #1 ' كتابة الأسطر التالية فى الملف النصى Print #1, "Thank you for trying out this product." Print #1, "If it meets your Requirements, visit :" Print #1, "http://www.officena.com " Print #1, "to purchase the full version..." Print #1, "" Print #1, " --------- Regards -------------" Print #1, "Mokhtar Hussien officena team" Close #1 ' غلق الملف النصى End Sub الكود يوضع فى حدث Workbook بامكانك تعديل مسار الملف النصى وبامكانك تعديل الفترة التجريبية الى مدة زمنية محددة أو شهور أو سنوات كما يتضح فى التعليق المحرر فى الكود لتجربة الكود : اذهب الى الملف النصى ستجد رقما زى كده : 42298.7085185185 ده هو وقت تشغيل الملف نقص الفترة التجريبية المحددة فى الكود من الرقم الصحيح 42298. يعنى نخلية 42250 مثلا ونحفظ الملف النصى على كدة روح افتح الملف هتلاقى الملف يقلك لا شكرا على كده وهحفظلك بياناتك عشان متزعلش مرفق للتجربة : Trial Version Ended 30 days.rar

الاخ أبو احمد ممكن يتعمل انتظر أحد الاخوة للرد للأسف أعمل على اكسل 2010 مش xp ولا 2003 لو عندك 2007 أو أعلى أخبرنى حيث لكل صندوق حوارى أمر استدعاء خاص تحياتى أمر التوسيط بالكود Sub MokhtarTest() Application.Dialogs(xlDialogAlignment).Show End Sub أمر نوع وحجم الخط Sub MokhtarTest2() Application.Dialogs(xlDialogFont).Show End Sub أو Sub MokhtarTest3() Application.Dialogs(xlDialogFontProperties).Show End Sub لاظهار صندوق الحماية الذى لا تريده Sub MokhtarTest4() Application.Dialogs(xlDialogCellProtection).Show End Sub ده متوفر فى 2007 فما فوق تحياتى

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

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

الطريقه الٍسابعه :- تعبئه الكمبوبوكس بدون تكرار باستخدام الحلقه التكراريه For Each و الداله Countif (طريقه احترافيه) لو عندى شيت زى كدا وفيه بيانات وعايز اقوم بتعبئة الكمبوبوكس بالبيانات المظلله باللون الاخضر ولكن دون تكرارشاهد الصوره هنستخدم نفس الكود السابق ولكن مع اضافه الداله Countif الكود هيكون كالتالى With ComboBox1 For Each Data In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row) i = Data.Row aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) If aa = 1 Then .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value End If Next End With أنا هحاول بقدر الامكان اعيشك فيديو تشوف الكود اثناء التنفيذ بيعمل ايه السطرالاول هو With ComboBox1 يعنى بنقول للكود الشغل بتاعنا هيكون مع الكمبوبوكس 1 ( الكمبوبوكس المطلوب تعبئته ) السطر الثانى هو الحلقة التكرارية For Each وقمنا بتسميتها اسم افتراضى وليكن Data ( وممكن تسميها اى اسم او حرف او مجموعه من الحروف ) طيب Data وين موجوده فى اى نطاق قلتله فى In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row يعنى النطاق من A2 الى اخر خلية بها بيانات فى العمود A اللى هى بالصوره السابقه A7 ( طبعا عرفنا ازاى نكتب سطر البحث عن اخر خليه بها بيانات) كدا عرفنا النطاق وهيكون من A2 :A7 طبقا للصوره موضوع الشرح ( وطبعا عند زياده المدى وليكن كتابة اسم جديد فى الخلية A8 سوف يقوم الكود بمعرفه النطاق من A2:A8 ) الحلقه دلوقتى عرفت النطاق بتاعها وهتبدأ تلف على خلية خلية فى هذا النطاق وكل مره هيكون الحلقه Data لها اسم خليه معينه فى المره الاولى سيكون قيمة Data هى A2 والكود هينتقل الى السطر التالى وهو i = Data.Row عملت متغير اسمه i وقلت أن i تساوى Data.Row يعنى رقم الصف اللى فيه Data دلوقتى Data هى A2 والخلية A2 كم رقم الصف بتاعها هو الصف رقم 2 أذن i = 2 الكود هيروح للسطر اللى بعد كدا وهو aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) هنا عملت متغير وسميتها aa وقلت ان aa تساوى قيمة معادله ما هى المعادله هى Countif وهى تعنى عمل احصاء على شئ ما داخل نطاق محدد عند الاعلان عن معادله فى اى كود لازم نكتب الجمله دى .Application.WorksheetFunction ثم اسم الداله اللى انت عايزها انا دلوقتى محتاج الداله Countif وهى ( CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data نطاق العمل هو المظلل باللون الاحمر وشرط الاحصاء هو اللون الاخضر جزء النطاق هو ( الى , من )Sheet1.Range السؤال هنا من ايه ؟ الى ايه؟ من A2 بس فى الكود مش هكتبها A2 هستخدم Cells و Cells عباره عن (رقم العمود, رقم الصف)Cells ِA2 كم رقم الصف بتاعها رقم 2 وكم رقم العمود بتاعها رقمه 1 اذن A2 تساوى (Cells(2, 1 الى ايه ؟ الى اى خلية ؟ الى هنا هتكون متغيره انا بالمره الاولى عايزه الى A2 والمره التانيه الى A3 والمره الثالثه الى A4 وهكذا طيب ودى بقى اكتبها ازاى ؟ ركز معايا يا عبدالتواب شايفك نمت منى فى Cells مش احنا قلنا ان Cells عباره عن (رقم العمود, رقم الصف)Cells طيب رقم الصف كل مره هو اللى مش معروف لكن رقم العمود هو اللى معروف طيب اعرف ازاى رقم الصف علشان كدا انا عرفت المتغير i فى السطر الثالث بالكود i = Data.Row فنكتب الى كدا (Cells(i, 1 الصف متغير من خلال i والعمود ثابت وهو عمود A ورقمه 1 اذن النطاق فى اول لفه للكود هيكون من A2:A2 وشرط الاحصاء هو Data اللى هى قيمة الخلية A2 ( عبدالله باقشير) فالمعادله aa هيكون كم 1 طبعا ليه لان عبدالله باقشير فى النطاق من A2:A2 مظهرش غير مره وحده فقط بعد كدا الكود هينتقل الى السطر التالى وهو If aa = 1 Then استخدمت If لاختبار قيمة aa هل هى تساوى 1 أو لا اذا كانت 1 نفذ السطر اللى بعده واذا مش تساوى 1 اقفل if وانتقل الى Next طبعا فى اللفه الاولى اللى احنا فيها دلوقتى aa = 1 فهينفذ المطلوب وهو السطرين التاليين .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value ترتيب الاعمده فى الكمبوبوكس بيدأ من 0 وكذالك ترتيب الصفوف بيدأ من 0 AddItem هى العمود رقم 0 فى الكمبوبوكس والعمود ده يساوى Data اللى هى كل خليه هتمر فيها الحلقه اللى هى اسماء العملاء بالعمود A والعمود رقم 1 فى الكمبوبوكس هو (List(.ListCount - 1, 1. هيظهر فيه كود العميل اللى بالعمود B (رقم العمود , صفوف الكمبوبوكس)List. صفوف الكمبوبوكس بتبدأ من 0 زى ما قلت علشان كدا قلت ان صفوف الكمبوبوكس - 1 **** ListCount - 1. طيب العمود رقم 1 عايزين نظهر فيه الكود اللى بالعمود B بالشيت فنعمل ايه Data.Offset(0, 1).Value= هنا استخدمنا الداله offset فى اول لفه للحلقه هيكون Data = A2 فأنا بقوله انتقل من A2 بمقدار صف 0 والعمود 1 ( يعنى ايه صف 0 يعنى نفس الصف والعمود واحد يعنى تحرك وروح للعمود B كدا فى اول لفه للحلقه دخل اسم عبدالله باقشير فى العمود الاول للكمبوبوكس ودخل كود العميل وهو 101 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A3 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A3 والخلية A3 كم رقم الصف بتاعها هو الصف رقم 3 أذن i = 3 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 3 اذن (Cells(3, 1 وهى تعنى الخلية A3 يعنى نطاق هو من A2:A3 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A3 (ياسر خليل ) كم مره ظهر اسم ياسر خليل فى النطاق من A2:A3 ظهر مره وحده اذن المتغير aa = 1 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط محقق لان aa = 1 فهينفذ السطريين التاليين .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value يعنى هيدخل ياسر خليل فى العمود الاول للكمبوبوكس وهيدخل الكود بتاعه 102 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A4 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A4 والخلية A4 كم رقم الصف بتاعها هو الصف رقم 4 أذن i = 4 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 4 اذن (Cells(4, 1 وهى تعنى الخلية A4 يعنى نطاق هو من A2:A4 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A4 (عبدالله باقشير ) كم مره ظهر اسم عبدالله باقشير فى النطاق من A2:A4 ظهر مرتين اذن المتغير aa = 2 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط لم يتحقق لان aa = 2 فمش هينفذ السطريين التاليين لان انا مش عايز الاسم يكرر فى الكمبوبوكس يظهر فقط مره وحده .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A5 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A5 والخلية A5 كم رقم الصف بتاعها هو الصف رقم 5 أذن i = 5 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 5 اذن (Cells(5, 1 وهى تعنى الخلية A5 يعنى نطاق هو من A2:A5 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A5 (محمد حسن المحمد) كم مره ظهر اسم محمد حسن المحمد فى النطاق من A2:A5 ظهر مره وحده اذن المتغير aa = 1 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط محقق لان aa = 1 فهينفذ السطريين التاليين .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value يعنى هيدخل محمد حسن المحمد فى العمود الاول للكمبوبوكس وهيدخل الكود بتاعه 103 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A6 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A6 والخلية A6 كم رقم الصف بتاعها هو الصف رقم 6 أذن i = 6 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 5 اذن (Cells(6, 1 وهى تعنى الخلية A6 يعنى نطاق هو من A2:A6 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A6 (عبدالعزيز البسكرى) كم مره ظهر اسم عبدالعزيز البسكرى فى النطاق من A2:A6 ظهر مره وحده اذن المتغير aa = 1 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط محقق لان aa = 1 فهينفذ السطريين التاليين .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value يعنى هيدخل عبدالعزيز البسكرى العمود الاول للكمبوبوكس وهيدخل الكود بتاعه 104 فى العمود الثانى للكمبوبوكس هيقفل If ثم ينتقل الى السطر التالى وهو Next Next تعنى ارجع للحلقه For Each مره اخرى فلما يرجع هيكون Data تساوى قيمة A7 ثم ينتقل الى السطر التالى وهو i = Data.Row دلوقتى Data هى A7 والخلية A7 كم رقم الصف بتاعها هو الصف رقم 7 أذن i = 7 هينتقل الى السطر اللى بعده وهو سطر المعادله aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) (Cells(2, 1 اللى هى A2 و (Cells(i, 1 المتغير i دلوقتى رقمه 7 اذن (Cells(7, 1 وهى تعنى الخلية A7 يعنى نطاق هو من A2:A7 وشرط الاحصاء هو Data وقيمتها الحاليه فى هذه الفه A7 (ياسر خليل) كم مره ظهر اسم ياسر خليل فى النطاق من A2:A7 ظهر مرتين اذن المتغير aa = 2 الكود هينتقل الى السطر التالى If aa = 1 Then طبعا الشرط لم يتحقق لان aa = 2 فمش هينفذ السطريين التاليين لان انا مش عايز الاسم يكرر فى الكمبوبوكس يظهر فقط مره وحده .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value هيقفل If ثم ينتقل الى السطر التالى وهو Next Next طبعا مش هيرجع فى هذه المره الى الحلقه لان النطاق انتهى وهينتقل الى End With كدا الكود انتهى وانا بصراحه انتهيت معاه من كتر اللف طبعا الكود بينفذ الكلام ده فى لمح البصر دون ان تشعر ولكن لو مساحه النطاق كبير مثلا من A2:A1000 سوف تبدأ تشعر ببطئ الكود ممكن مثلا ياخد 30ثانيه اخر شئ طبعا الكود ده وقت تنفيذه انت اللى بتحدده ولكن على سبيل المثال انا عايز اكتبه فى حدث تشغيل الفورم فيكون كالتالى Private Sub UserForm_Initialize() With ComboBox1 For Each Data In Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row) i = Data.Row aa = Application.WorksheetFunction.CountIf(Sheet1.Range(Cells(2, 1), Cells(i, 1)), Data) If aa = 1 Then .AddItem Data .List(.ListCount - 1, 1) = Data.Offset(0, 1).Value End If Next End With End Sub وعند تشغيل الفورم ستجد الصوره التاليه لاحظ فى الصوره ان الكمبوبوكس يعرض فقط الاسماء دون تكرار ********************************************************************************************* والى لقاء اخر من حلقات سلسلة علمنى كيف اصطاد وطريقه اخرى من طرق تعبئة الكمبوبوكس الطريقه القادمه هنعرف ازاى نجلب البيانات بالكمبوبوكس دون تكرار بطريقه اخرى انتظرونا تقبلوا تحياتى

أخي العزيز / أبو حنين إضافة لحلول الأساتذة الكرام طلعت محمد حسن و خالد الرشيدي هذا حل عن طريق التصفية المتقدمة قد قمت بإعداده فأحببت أن أشارك زملائي الكرام في ذلك حيث معيار التصفية هو النطاق ( S1:X2 ) تقبل تحياتي وتقديري لكم وللأساتذة الكرام طلعت محمد و خالد الرشيدي Book1.rar

الاخوة الكرام فى هذا الصرح العظيم بناء على طلب للاخ " المارد العراقى " على هذا الرابط http://www.officena.net/ib/topic/64162-موضوع-خاص-بالردود-والاستفسارات-واسئله-اختبارات-على-شروحات-الفورم-سلسلة-علمنى-كيف-اصطاد/?do=findComment&comment=418485 قمت بعمل طلبه وحبيت يكون فى موضوع مستقل حتى تعم الفائده ويكون سهل فى الوصول اليه من خلال البحث فيما بعد الطلب كان السلام عليكم أستاذ عندي 3 (textbox) الاول يحتوي على تاريخ اليوم والثاني يحتوي تاريخ الشهر والثالث تاريخ السنه بالميلادي و عندي تكست رابع اريد ان اجعل التاريخ في التكست الرابع يمثل تاريخ التكست الثلاثه السابقه ولكن بالهجري بأستخدام اليوزر فورم دون الرجوع او استخدام الخلايا في الاكسل على سبيل المثال التكست الاول يساوي 22 الي هو اليوم ولثاني يساوي 2 الي هو الشهر والثالث يساوي 2000 كيف اجعل التكست الرابع يساوي ( 18 / 11 /1420) الي هوه التاريخ الهجري لتلك السنه بواسطة vba فقط دون استخدام خلايا الاكسل ؟؟ مرفق ملف به ما تريد الملف الاول تحويل التاريخ من يوم وشهر وسنة تحويل التاريخ من ميلادى الى هجرى على الفورم.zip الملف الثانى تحويل التاريخ بنفس التكست تحويل التاريخ من ميلادى الى هجرى على الفورم - Copy.zip تقبلوا تحياتى

السلام عليكم ورحمة الله وبركاته . مشكلة الفرز SORT فى الاكسيل هل لاحظت فى احدى المرات بعد قيامك بعمل فرز SORT انه لايمكن التراجع او الرجوع الى الحالة الطبيعية الى ماقبل الفرز ؟ فى هذا الفيديو نتحايل على هذه المشكلة قبل الوقع فيها باستخدام عمود ... اترككم مع الفيديو.... ولاتنسونا بصالح دعاؤكم ملف التطبيق فى رابط داخل الفيديو

حدد فقط الصف الذي تريد اكسل يخفي لك كل شيء و لا ترى الا ما تريد بكبسة زر show_in top.zip

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

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

أستاذي الفاضل ياسر خليل أبو البراء بارك الله فيك :) تم حفظ المنتدى في المفضلة Bookmarked

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

كنت معدي من هنا بالصدفة بضطلع بشكل عام على ما يمكن تحقيقه بالـ في بي إيه وشوفت شغل عظيم ومجهودات رائعة وروح طيبة جزاكم الله خيراً جميعاً على هذا الصرح الكبير

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

اخي ياسر اثراء للموضوغ اليك هذا الكود تستطيع ان تحدد اكثر من صف و اكثر من عامود للنكرار Sub repet() Dim myrg As Range Dim t As Integer Set myrg = Application.InputBox("Enter your data", Type:=8) t = Application.InputBox("Enter your number", Type:=1) myrg.Copy ActiveCell.Resize(t * myrg.Rows.Count, myrg.Columns.Count) End Sub

أخي وحبيبي في الله أبو يوسف لا أعرف من هو (لوزتين بدخل) .. ولكن يبدو أن عقلي أيضاً مثل عقله بالنسبة لمشكلة الانترنت أقترح استخدام الإضافة المرفقة في المشاركة ... قم بتحميل الإضافة المسماة Mozilla Archiver Format ثم فك الضغط عنها لتجد الملف المسمى Mozilla Archiver Format.xpi من خلال الفايرفوكس روح على قايمة Tools ثم اختر الأمر Add-ons ستجد علامة تشبه الترس وبجانبها سهم .. على أنها قائمة منسدلة اختر الأمر Install Add-on from File ، ستظهر لك نافذة تحدد من خلالها مكان الإضافة التي لها الامتداد xpi ، ثم تظهر رسالة فيها أمرين أحدهما Install لتأكيد تنصيب الإضافة والأخرى Cancel لإلغاء الأمر قم بإغلاق الفايرفوكس ثم أعد فتحه افتح أي موضوع من موضوعات المنتدى التي تريد حفظها لتصفحها في وقتٍ لاحق .. ومن خلال قائمة File في المتصفح الفايرفوكس ستجد الأمر المسمى Save Page In Archive As ستفتح لك نافذة الحفظ التي تسمي فيها الملف الأرشيف وتحدد مكانه .. يمكنك تصفح الصفحة وكأنك داخل انترنت بالضبط جرب الإضافة ولا تنساني من دعائك تقبل تحياتي Mozilla Archiver Format.rar

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

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

أخي الكريم كريم إليك الكود التالي عله يفي بالغرض Sub CopyData() Dim Rng As Range, xValue, xNum Dim InputRng As Range, OutRng As Range On Error Resume Next Set InputRng = Application.Selection Set InputRng = Application.InputBox("حدد النطاق المراد تكراره", "Officena", InputRng.Address, Type:=8) Set OutRng = Application.InputBox("حدد الخلية التي تريد وضع النتائج بها", "Officena", Type:=8) Set OutRng = OutRng.Range("A1") For Each Rng In InputRng.Rows xValue = Rng.Range("A1").Value xNum = Rng.Range("B1").Value OutRng.Resize(xNum, 1).Value = xValue Set OutRng = OutRng.Offset(xNum, 0) Next End Sub قم بتنفيذ الكود .. حدد النطاق المراد تكرار قيمه (على أن يكون في الخلية المجاورة عدد مرات التكرار) .. حدد أول خلية في نطاق النتائج .. انتهى Repeat Cell Values X Times.rar

السلام عليكم : يمكن المشكلة لها علاقة بنسخة اكسس في مثل هذه الحالاات الجأ غالبا الى حلين اثنين لا ثالث لهما 1- تجربة نقل جميع الكائنات الى قاعدة جديدة 2- استبدال نسخة اوفس باخرى جديدة لرفع النسخة على الموقع اعمل ضغط واصلاح لها لتخفيف الحجم ثم ااضغطها باحد برامج الضغط : رار او غيره وان كان حجمها كبير فارفعها على احد المواقع المتخصصة بالرفع

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

حياك الله استاذ وائل - انته متميز وحلك متميز - شكراً يا متميز تسلموووووا

السلام عليكم ورحمة الله وبركاته الدرس الثاني عشر 12-Window Events وسوف نتناول فى هذه الدرس الاتى تغيير التسمية التوضيحية لإسم نافذة المصنف النشط تنشيط نافذة معينه مفتوحه إخفاء أو إظهار نافذة مصنف مفتوح إغلاق نافذة مصنف فتح نافذه جديد لمصنف معين تكبير أو تصغبر أو الوضع العادى لنافذة مصنف عمل زووم لنافذة معينه إخفاء علامات التبويب لأوراق العمل فى مصنف معين إخفاء رؤوس الأعمدة والصفوف فى مصنف معين إخفاء شريط التمرير الأفقي فى مصنف معين إخفاء شريط التمرير العمودي فى مصنف معين عرض جميع صيغ المعدلات فى مصنف معين إخفاء خطوط الشبكة فى مصنف معين تلوين خطوط الشبكة فى مصنف معين عمل معاينة لفواصل الصفحات فى مصنف معين إخفاء القيم الصفرية فى مصنف معين اظهار اسم الورقة النشطه في رساله اظهار عنوان الخلية النشطة فى مصنف معين في رساله اظهار عنوان مدى محدد في رساله تجميد الألواح داخل فى مصنف معين عمل انقسام فى مصنف معين ................................................................................................................................................................................. تغيير التسمية التوضيحية لإسم نافذة المصنف النشط لاحظ هنا ان اسم المصنف المفتوح امامك هو LEARN--VBA.xlsb طب لو احنا عايزين نغيره ونخليه مثلا مش مهم تكون محترفvbaالمهم تكون عندك معلومات عنvba.xlsb سيكون شكل الكود Sub A_Window_Caption() ActiveWindow.Caption = "مش مهم تكون محترفvbaالمهم تكون عندك معلومات عنvba.xlsb" End Sub تنشيط نافذة معينه مفتوحه كما يتضح من الصوره ان هناك اكثر من نافذة اكسيل مفتوحه ولكن المصنف النشط هو 9-sky201.xlsb فلو افترضنا اننا نريد اننا عايزين نخلى المصنف النشط هو LEARN--VBA.xlsb ليصبح هكذا سيكون شكل الكود Sub Windows_Activate() Windows("LEARN--VBA.xlsb").Activate End Sub إخفاء أو إظهار إطار نافذة مصنف مفتوح كما يتضح من الصوره اننا لدينا اكثر من مصنف مفتوح فلو اردنا اخفاء نافذه المصنف 9-sky201.xlsb سيكون شكل الكود Sub Windows_Visible() ' اخفاء Windows("9-sky201.xlsb").Visible = False ' اظهار 'Windows("9-sky201.xlsb").Visible = True End Sub إغلاق نافذة مصنف فلو اردنا اغلاق نافذة المصنف 9-sky201.xlsb سيكون الكود كالاتى Sub Windows_CLOSE() Windows("9-sky201.xlsb").Close = True End Sub فتح نافذه جديد لمصنف معين فى الصوره يتضح ان المصنف LEARN--VBA.xlsb مفتوح مره واحده ولفتحه مرتين هكذا لاحظ فى الصوره انه تم اضاف شيت جديد باسم افتراضى LEARN--VBA.xlsb:2 وتم تميز المصنف الاول باسم LEARN--VBA.xlsb:1 وعند غلق اى من المصنفين يتم اعادة اسم المصنف كما كان LEARN--VBA.xlsb سيكون الكود كالاتى Sub NewWindow_() Windows("LEARN--VBA.xlsb").NewWindow End Sub تكبير أو تصغبر أو الوضع العادى لنافذة مصنف سيكون الكود كالاتى Sub WindowState_() 'الوضع العادى Windows("LEARN--VBA.xlsb").WindowState = xlNormal 'تكبير 'Windows("LEARN--VBA.xlsb").WindowState = xlMaximized ' تصغير 'Windows("LEARN--VBA.xlsb").WindowState = xlMinimized End Sub عمل زووم لنافذة معينه سيكون الكود كالاتى Sub WindowZOOM_() Windows("LEARN--VBA.xlsb").Zoom = 80 End Sub إخفاء علامات التبويب لأوراق العمل فى مصنف معين لاحظ اختفاء اسماء الشيتات بعد تنفيذ الكود سيكون الكود كالاتى Sub DisplayWorkbookTabs_() ' اخفاء Windows("LEARN--VBA.xlsb").DisplayWorkbookTabs = False ' اظهار 'Windows("LEARN--VBA.xlsb").DisplayWorkbookTabs = True End Sub إخفاء رؤوس الأعمدة والصفوف بمصنف معين سيكون الكود كالاتى Sub DisplayHeadings_() ' اخفاء Windows("LEARN--VBA.xlsb").DisplayHeadings = False ' اظهار 'Windows("LEARN--VBA.xlsb").DisplayHeadings = True End Sub إخفاء شريط التمرير الأفقي فى مصنف معين سيكون الكود كالاتى Sub DisplayHorizontalScrollBar_() ' اخفاء Windows("LEARN--VBA.xlsb").DisplayHorizontalScrollBar = False ' اظهار 'Windows("LEARN--VBA.xlsb").DisplayHorizontalScrollBar = True End Sub إخفاء شريط التمرير العمودي فى مصنف معين سيكون الكود كالاتى Sub DisplayVerticalScrollBar_() ' اخفاء Windows("LEARN--VBA.xlsb").DisplayVerticalScrollBar = False ' اظهار 'Windows("LEARN--VBA.xlsb").DisplayVerticalScrollBar = True End Sub عرض جميع صيغ المعدلات فى مصنف معين سيكون الكود كالاتى Sub DisplayFormulas_() ' اخفاء Windows("LEARN--VBA.xlsb").DisplayFormulas = False ' اظهار 'Windows("LEARN--VBA.xlsb").DisplayFormulas = True End Sub إخفاء خطوط الشبكة فى مصنف معين سيكون الكود كالاتى Sub DisplayGridlines_() ' اخفاء Windows("LEARN--VBA.xlsb").DisplayGridlines = False ' اظهار 'Windows("LEARN--VBA.xlsb").DisplayGridlines = True End Sub تلوين خطوط الشبكة فى مصنف معين سيكون الكود كالاتى Sub DisplayGridlines_() Windows("LEARN--VBA.xlsb").GridlineColorIndex = 5 End Sub عمل معاينة لفواصل الصفحات فى مصنف معين سيكون الكود كالاتى Sub WindowView_() Windows("LEARN--VBA.xlsb").View = xlNormalView End Sub إخفاء القيم الصفرية فى مصنف معين سيكون الكود كالاتى Sub DisplayZeros_() ' اخفاء Windows("LEARN--VBA.xlsb").DisplayZeros = False ' اظهار 'Windows("LEARN--VBA.xlsb").DisplayZeros = True End Sub اظهار اسم الورقة النشطه في رساله سيكون الكود كالاتى Sub MsgBoxActiveSheet_() MsgBox Windows(1).ActiveSheet.Name End Sub اظهار اسم الخليه النشطه محدد في رساله Sub MsgBoxActiveSheet_() MsgBox Windows("LEARN--VBA.xlsb").ActiveCell.Address End Sub اظهار عنوان مدى محدد في رساله Sub MsgBoxRangeSelection_() MsgBox Windows("LEARN--VBA.xlsb").RangeSelection.Address End Sub تجميد الألواح داخل فى مصنف معين Sub MsgBoxActiveSheet_() Windows("LEARN--VBA.xlsb").FreezePanes = True 'Windows("LEARN--VBA.xlsb").FreezePanes = false End Sub عمل انقسام فى مصنف معين Sub Split_() Windows("LEARN--VBA.xlsb").Split = True 'Windows("LEARN--VBA.xlsb").Split = false End Sub اتمنى ان يكون الدرس مفيدا مرفق شيت اكسيل به التطبيقات learnvba.rar تقبلوا تحياتى

وعليكم السلام برجاء الاطلاع على المرفق وزارات المحافظة_ البيانات الاضافية.rar

ربنا يعزك ويبارك فيك يابشمهندس ياسر

غير الرقم 30 الى: inputbox("ادخل عدد التكرار") بالتوفيق

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

بعد إذن أستاتذتي الأفاضل .. فأنا مجرد تلميذ في منتداكم الراقي .. هذه محاولة مني أخي الفاضل لا ادري إن كانت مناسبة لك ام لا وفقا لكلامك أن كل رقم يحتوي على 8 أرقام .. ولكن وجدت بعض الأرقام تحتوي على 7 ارقام فقط .. فمت بإفتراض ان الارقام من 1 إلى 9 تاخذ حرف EE أسمحوا لي أن أعرف إن كان لديك إستفسار آخر استبدال حرف بقيمة.rar

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

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

طيب ما تحط رقم الهاردين انظر المرفق ملف يعمل علي جهازين.rar

اخي جرب المرفق التالي تحياتي Report.rar

لو تعمل repair ممكن يزبط بس لازم يكون عندك office setup

اضف هذا السطر في اول الكود السابق If MsgBox("استمرار ؟", vbYesNo) = vbNo Then: Exit Sub بالتوفيق

تفضل وبلصق هذا الكود خلف زر امر على النموذج ولعله ماتريد DoCmd.GoToRecord , , acLast DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdCopy For i = 1 To 30 DoCmd.GoToRecord , , acNewRec DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdPaste Next i بالتوفيق

السلام عليكم تفضلوا التسخة 64 بيت ... كتبت الكود و جربته على ال Windows7 64bit Office10 64bit ملف للتحميل: https://app.box.com/s/cvjs3lt381ts805zu8v1uzu0ooxu4i80 الكود في ستاندر موديول Option Explicit Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As LongPtr End Type Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long Private Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String) As Long Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Const WS_CHILD = &H40000000 Private Const WS_CLIPCHILDREN = &H2000000 Private Const WS_CAPTION = &HC00000 Private Const WS_EX_TOPMOST = &H8& Private Const SW_NORMAL = 1 Private Const TRANSPARENT = 1 Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const COLOR_BTNFACE = 15 Private bWindowExist As Boolean Public Sub Test() If Not bWindowExist Then Call ShowUpdatingMessage( _ Message:="Showing message number : ", _ Title:="Officena", _ HowManyTimes:=10, MessageDelay:=1, _ TOPMOST:=True, TextColor:=vbRed, BackColor:=vbYellow _ ) End If End Sub Private Sub ShowUpdatingMessage( _ ByVal Message As String, _ ByVal Title As String, _ ByVal HowManyTimes As Single, _ Optional ByVal MessageDelay As Single, _ Optional ByVal TOPMOST As Boolean, _ Optional ByVal TextColor As Long, _ Optional ByVal BackColor As Long) Const WIDTH = 250 Const HEIGHT = 120 Dim tRect As RECT Dim tLb As LOGBRUSH Dim t As Single Dim hBrush As LongPtr Dim hwndChild As LongPtr Dim hWndParent As LongPtr Dim hdc As LongPtr Dim iCounter As Integer On Error GoTo CleanUp ' Application.EnableCancelKey = xlErrorHandler hWndParent = CreateWindowEx(IIf(TOPMOST, WS_EX_TOPMOST, 0), "BUTTON", Title, WS_CAPTION + WS_CLIPCHILDREN, _ (GetSystemMetrics(SM_CXSCREEN) - WIDTH) / 2.2, (GetSystemMetrics(SM_CYSCREEN) - HEIGHT) / 2, WIDTH, HEIGHT, 0, ByVal 0, 0, ByVal 0&) hwndChild = CreateWindowEx(0, "STATIC", vbNullString, WS_CHILD, 0, 0, WIDTH, HEIGHT, hWndParent, ByVal 0&, ByVal 0, ByVal 0&) If hwndChild Then bWindowExist = True Application.OnKey "%{F4}", "" ShowWindow hWndParent, SW_NORMAL ShowWindow hwndChild, SW_NORMAL DoEvents hdc = GetDC(hwndChild) SetBkMode hdc, TRANSPARENT If TextColor <> 0 Then SetTextColor hdc, TextColor End If SetRect tRect, 0, 0, WIDTH, HEIGHT tLb.lbColor = IIf(BackColor = 0, GetSysColor(COLOR_BTNFACE), BackColor) hBrush = CreateBrushIndirect(tLb) For iCounter = 1 To HowManyTimes FillRect hdc, tRect, hBrush TextOut hdc, 30, 20, Message, Len(Message) TextOut hdc, 115, 50, CStr(iCounter), Len(CStr(iCounter)) t = Timer Do DoEvents Loop Until Timer - t >= IIf(MessageDelay = 0, 1, MessageDelay) Next End If CleanUp: ReleaseDC hwndChild, 0 DeleteObject hBrush DestroyWindow hwndChild DestroyWindow hWndParent bWindowExist = False Application.OnKey "%{F4}" End Sub

وهذا حل آخر إثراءً للموضوع الدالة المعرفة Function Kh_Names(FullName As String, ParamArray Index1()) As String Dim I As Integer Dim Kh_Split, MyArray, Arr Dim Kh_String As String, SN As String, RE As String On Error GoTo Err_Kh_Names MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله") SN = Application.WorksheetFunction.Trim(FullName) For Each Arr In MyArray RE = Replace(Arr, " ", "^") SN = Replace(SN, Arr, RE) Next Kh_Split = Split(SN, " ", , vbTextCompare) On Error Resume Next For I = 0 To UBound(Index1) Kh_String = Kh_String & " " & Kh_Split(Index1(I) - 1) Next On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") Kh_Names = Kh_String Exit Function Err_Kh_Names: Kh_Names = "" End Function Split Full Names UDF Function.rar أخي الحبيب توكل لم أطلع على حلك إلا بعد أن قدمت المشاركة الخاصة بي فأعتذر عن تكرار الحل .. إذا أنها تقريباً نفس الدالة المعرفة المستخدمة تقبل تحياتي

السلام علبكم ملف للتحميل : https://app.box.com/s/72jzyfczsk6bvsedm57h6ycv12agxgv9 نسخة 64 بيت .. حربتها على Windows7 64 bit Office 2010 64 bit - كود في موديول الفورم: PaintingPuzzleGame Option Explicit Private Type POINTAPI x As Long y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type PICTDESC Size As Long Type As Long hPic As LongPtr hPal As LongPtr End Type Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Long, ByVal bErase As Long) As Long Private Declare PtrSafe Function MessageBeep Lib "user32" (ByVal wType As Long) As Long Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare PtrSafe Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As Long) As Long Private Const PICTYPE_BITMAP = &H1 Private Const SRCCOPY = &HCC0020 Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const SND_ASYNC = &H1 Private Const SND_FILENAME = &H20000 Private Const SND_LOOP = &H8 Private Const SND_PURGE = &H40 'Module level variables Private oCol As Collection Private oPic As Object Private bScore As Boolean Private bExit As Boolean Private bAbort As Boolean Private InitialFormLeft As Single Private InitialFormTop As Single Private lFrmHwnd As LongPtr Private lCounter As Long Private lTotalImageParts As Long Private lColumns As Long Private lRows As Long Private sLevel As String Private sUserName As String Private vFileName As Variant Private Sub UserForm_Initialize() sUserName = InputBox("Please, enter your name", "Player Name") If Len(sUserName) = 0 And StrPtr(sUserName) <> 0 Then MsgBox "You must enter a player name", vbInformation: End If StrPtr(sUserName) = 0 Then End End Sub Private Sub UserForm_Activate() StartUpPosition = 2 InitialFormLeft = Me.Left InitialFormTop = Me.Top Set oPic = frameSourcePic.Picture lFrmHwnd = FindWindow(vbNullString, Me.Caption) frameSourcePic.BorderStyle = fmBorderStyleSingle frameSourcePic.BorderColor = vbYellow With Me.ComboLevel .AddItem "Easy " & " (3x6 Parts)" .AddItem "low " & " (3x8 Parts)" .AddItem "Medium " & "(4x10 Parts)" .AddItem "High " & "(6x13 Parts)" .ListIndex = 0 End With lblTimer.Caption = "" CBtnAbort.Enabled = False Call EnableControls(True) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If MsgBox("Are you sure you want to quit ?", vbQuestion + vbYesNo) = vbNo Then Cancel = 1 Exit Sub End If bExit = True End Sub '*************************************************************************************************** 'Event handlers of form's controls Private Sub ComboLevel_Change() Select Case True Case UCase(ComboLevel.Value) Like "EASY*" lRows = 3 lColumns = 6 Case UCase(ComboLevel.Value) Like "LOW*" lRows = 3 lColumns = 8 Case UCase(ComboLevel.Value) Like "MEDIUM*" lRows = 4 lColumns = 10 Case UCase(ComboLevel.Value) Like "HIGH*" lRows = 6 lColumns = 13 End Select sLevel = UCase(ComboLevel.Value) End Sub Private Sub CBtnAbort_Click() Call EnableControls(False) bAbort = True End Sub Private Sub CBtnClose_Click() Unload Me End Sub Private Sub CBtnNewPic_Click() On Error GoTo errHandler vFileName = Application.GetOpenFilename(FileFilter:="Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp", _ Title:="Select Picture") If vFileName <> False Then frameSourcePic.Picture = LoadPicture(vFileName) Call DeletePreviousImages End If Exit Sub errHandler: MsgBox Err.Description End Sub Private Sub CBtnStart_Click() Dim oImagePartCls As oImagePartCls Dim oTextBox As msforms.TextBox Dim tRect As RECT Dim tPt1 As POINTAPI, tPt2 As POINTAPI Dim BasePicframeHwnd As Long Dim lImgPartWidth As Long, lImgPartHeight As Long Dim lImgPartLeft As Long, lImgPartTop As Long Dim lColumn As Long, lRow As Long Dim lControlCounter As Long bScore = False bAbort = False Call EnableControls(False) BasePicframeHwnd = frameSourcePic.[_GethWnd] GetWindowRect BasePicframeHwnd, tRect tPt1.x = tRect.Left tPt1.y = tRect.Top tPt2.x = tRect.Right tPt2.y = tRect.Bottom If IsFormClipped(tPt1, tPt2) Then Me.Move InitialFormLeft, InitialFormTop GetWindowRect BasePicframeHwnd, tRect DoEvents End If Call DeletePreviousImages 'add the image parts controls Set oCol = New Collection For lColumn = 1 To lRows For lRow = 1 To lColumns lControlCounter = lControlCounter + 1 Set oImagePartCls = New oImagePartCls Set oImagePartCls.GetForm = Me Set oImagePartCls.PicturePart = Controls.Add("Forms.Image.1", "Image" & lControlCounter) With oImagePartCls.PicturePart .PictureSizeMode = fmPictureSizeModeStretch .BorderStyle = fmBorderStyleSingle .BorderColor = vbYellow .MousePointer = fmMousePointerSizeAll .Width = frameSourcePic.Width / lRows .Height = frameSourcePic.Height / lColumns .Left = frameSourcePic.Left + (((lRow - 1) * (frameSourcePic.Width + 20) / lRows)) .Top = 20 + (((lColumn - 1) * (frameSourcePic.Height + 20) / lColumns)) .ZOrder 0 .ControlTipText = "Drag the Picture down to its corresponding empty frame below" End With oCol.Add oImagePartCls Next Next 'add the textbox holder controls lControlCounter = 0 For lRow = 1 To lColumns For lColumn = 1 To lRows lControlCounter = lControlCounter + 1 Set oTextBox = Controls.Add("Forms.TextBox.1", "TextBox" & lControlCounter) With oTextBox .Enabled = False .BackStyle = fmBackStyleTransparent .BorderStyle = fmBorderStyleSingle .SpecialEffect = fmSpecialEffectEtched .Left = frameSourcePic.Left + frameSourcePic.Width + 80 + lColumn * frameSourcePic.Width / lRows .Top = frameSourcePic.Top + (lRow - 1) * frameSourcePic.Height / lColumns .Width = oImagePartCls.PicturePart.Width .Height = oImagePartCls.PicturePart.Height .ZOrder 1 End With Next Next 'randomly shuffle the image part controls lTotalImageParts = lColumns * lRows Me.Tag = lTotalImageParts ReDim iArray(1 To lTotalImageParts) As Integer ' Call ShufflePictureParts(lTotalImageParts, iArray) 'set the Pic property of each image part lControlCounter = 0 For lColumn = 1 To lColumns For lRow = 1 To lRows With tRect lImgPartWidth = (.Right - .Left) / lRows lImgPartHeight = (.Bottom - .Top) / lColumns lImgPartLeft = .Left + ((lRow - 1) * lImgPartWidth) lImgPartTop = .Top + ((lColumn - 1) * lImgPartHeight) End With lControlCounter = lControlCounter + 1 Controls("image" & iArray(lControlCounter)).Tag = Controls("TextBox" & lControlCounter).Name CropPic lImgPartWidth, lImgPartHeight, lImgPartLeft, lImgPartTop, Me.Controls("image" & iArray(lControlCounter)) InvalidateRect lFrmHwnd, 0, 0 Next Next frameSourcePic.BorderStyle = fmBorderStyleSingle frameSourcePic.BorderColor = vbYellow Call UpdateTimerLabel End Sub '************************************************************************************************* ' Private Supporting routines Private Sub UpdateTimerLabel() Dim ss As Long Dim mm As Long Dim hh As Long Dim sglTimer As Single Const WAV_FILE As String = "C:\WINDOWS\MEDIA\tada.WAV" sglTimer = Timer Do ss = Int(Timer - sglTimer) If ss = 60 Then mm = mm + 1: ss = 0: sglTimer = Timer If mm = 60 Then hh = hh + 1: mm = 0: sglTimer = Timer lblTimer.Caption = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" DoEvents Loop Until bExit Or bScore Or bAbort If bScore Then PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_LOOP Or SND_ASYNC If MsgBox("Congratulations " & sUserName & " !!" & vbCrLf & vbCrLf & _ "You scored in : " & Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" & vbCrLf & _ "Do you want to save this score to your scores history ?", vbQuestion + vbYesNo) = vbYes Then Call SaveTheScore(hh, mm, ss) End If PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_PURGE End If lblTimer.Caption = "" Call EnableControls(True) Call DeletePreviousImages Set frameSourcePic.Picture = oPic End Sub Private Sub SaveTheScore(ByVal hh As Long, mm As Long, ByVal ss As Long) Dim bProtection As Boolean bProtection = ActiveSheet.ProtectContents If bProtection Then ActiveSheet.Unprotect End If With Cells(Cells.Rows.Count, 1).End(xlUp) .Offset(1, 0) = sUserName .Offset(1, 1) = Now .Offset(1, 2) = IIf(vFileName = Empty, "Default Picture", vFileName) .Offset(1, 3) = sLevel .Offset(1, 4) = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" End With If bProtection Then ActiveSheet.Protect End If ThisWorkbook.Save End Sub Private Sub CropPic(ByVal nWidth, ByVal nHeight, ByVal x, ByVal y, DestCtrl As Image) Dim hdc As LongPtr Dim hDCMemory As LongPtr Dim hBmp As LongPtr Dim OldBMP As LongPtr Dim IID_IDispatch As GUID Dim uPicinfo As PICTDESC Dim IPic As IPicture hdc = GetDC(0) hDCMemory = CreateCompatibleDC(hdc) hBmp = CreateCompatibleBitmap(hdc, nWidth, nHeight) OldBMP = SelectObject(hDCMemory, hBmp) Call BitBlt(hDCMemory, 0, 0, nWidth, nHeight, hdc, x, y, SRCCOPY) With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With With uPicinfo .Size = Len(uPicinfo) .Type = PICTYPE_BITMAP .hPic = hBmp .hPal = 0 End With OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic Set DestCtrl.Picture = IPic ReleaseDC 0, hdc DeleteObject OldBMP DeleteDC hDCMemory End Sub Private Sub ShufflePictureParts(ByVal NumOfPics, ByRef Arr() As Integer) Dim i As Integer, lRandomNumber As Integer, temp As Integer For i = 1 To NumOfPics Arr(i) = i Next i Randomize Timer For i = 1 To NumOfPics lRandomNumber = Int(Rnd * (UBound(Arr) - LBound(Arr) + 1) + LBound(Arr)) temp = Arr(i) Arr(i) = Arr(lRandomNumber) Arr(lRandomNumber) = temp Next i End Sub Private Sub DeletePreviousImages() Dim i As Long Dim oCtl As Control On Error Resume Next If Not oCol Is Nothing Then For i = 1 To oCol.Count Controls.Remove Controls("Image" & i).Name Next For Each oCtl In Me.Controls If TypeName(oCtl) = "TextBox" Then Controls.Remove oCtl.Name End If If TypeName(oCtl) = "Image" Then Controls.Remove oCtl.Name End If Next End If End Sub Private Function IsFormClipped(tLeftTop As POINTAPI, tRightBottom As POINTAPI) As Boolean IsFormClipped = _ tLeftTop.x <= 1 Or tLeftTop.y <= 1 Or tRightBottom.x >= GetSystemMetrics(SM_CXSCREEN) - 1 Or _ tRightBottom.y >= GetSystemMetrics(SM_CYSCREEN) - 1 End Function Private Sub EnableControls(ByVal Bool As Boolean) CBtnAbort.Enabled = Not Bool CBtnNewPic.Enabled = Bool CBtnStart.Enabled = Bool ComboLevel.Enabled = Bool End Sub '************************************************************************************************************* ' Public Methods Public Sub MsgbBeep() MessageBeep &H40& End Sub Public Sub FlashImagePart(ByVal Img As Image, ByVal ct As msforms.TextBox) Dim i As Long Dim t As Single For i = 0 To 1 Img.BorderStyle = fmBorderStyleSingle Img.BorderColor = vbRed t = Timer Do DoEvents Loop Until Timer - t >= 0.1 Img.BorderStyle = fmBorderStyleNone Next End Sub Public Sub CheckIfSuccess() Dim oCtrl As Control Dim lCounter As Long For Each oCtrl In Me.Controls If TypeName(oCtrl) = "Image" Then If InStr(1, oCtrl.Tag, "Success") Then lCounter = lCounter + 1 If lCounter = lTotalImageParts Then bScore = True End If End If End If Next End Sub - الكود في الكلاس موديول : oImagePartCls Option Explicit Public WithEvents PicturePart As msforms.Image Private initialY As Single, initialX As Single Private oUForm As Object Public Property Set GetForm(ByVal vNewValue As Object) Set oUForm = vNewValue End Property Private Sub PicturePart_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) initialX = x: initialY = y PicturePart.ZOrder 0 End Sub Private Sub PicturePart_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) Dim oCtrl As Control Static oPrevCtrl As Control If Button = 1 Then With PicturePart .Move .Left + (x - initialX), .Top + (y - initialY) For Each oCtrl In oUForm.Controls If TypeName(oCtrl) = "TextBox" Then If Not oPrevCtrl Is Nothing Then oPrevCtrl.Enabled = False oPrevCtrl.BackStyle = fmBackStyleTransparent oPrevCtrl.SpecialEffect = fmSpecialEffectEtched End If If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _ And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then oCtrl.Enabled = True oCtrl.BackStyle = fmBackStyleOpaque oCtrl.SpecialEffect = 6 oCtrl.BackColor = vbWhite Set oPrevCtrl = oCtrl Exit For End If End If Next End With End If End Sub Private Sub PicturePart_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) Dim oCtrl As Control For Each oCtrl In oUForm.Controls If TypeName(oCtrl) = "TextBox" Then With PicturePart If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _ And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then .Move oCtrl.Left, oCtrl.Top PicturePart.BorderStyle = fmBorderStyleNone Call oUForm.FlashImagePart(PicturePart, oCtrl) If InStr(1, PicturePart.Tag, oCtrl.Name) Then PicturePart.Tag = PicturePart.Tag & "Success" Else If Right(PicturePart.Tag, 7) = "Success" Then PicturePart.Tag = Mid(PicturePart.Tag, 1, Len(PicturePart.Tag) - 7) End If End If Call oUForm.MsgbBeep Call oUForm.CheckIfSuccess Exit For End If End With End If Next End Sub

السلام عليكم جزاك الله خيراً استاذى الفاضل / توكل .. لاثراء الموضوع ها هى طريقة اخرى بإستخدام المعادلات اخى الكريم قم بوضع المعادلة التالية فى الخلية B2 ثم السحب يساراً =SUBSTITUTE(TRIM(MID(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(" "&$G2;" "&"الدين";"#الدين");" "&"الله";"#الله");"عبد"&" ";"عبد#");"ابو"&" ";"ابو#");" ";REPT(" ";200));COLUMN(A1)*200;200));"#";" ") تجزئة الاسم الرباعي.rar - لست بحاجه الى كتابة الارقام 1 الى 5 -

اخى واستاذى / طلعت محمد حسن مشاركة متميزه جداً ... جزاك الله خيراً اخى الكريم اخى / ابو حنين اليك احد طرق الحل التى ليس بأفضلهم - تصفية وطباعة - Book1_2.rar

جرب اخي الغالي هذا وهل قام احد المشاركين في الموضوع بتجربة هذا الملف وظهر عنده نفس المشكلة؟؟؟؟ تجربة2.rar

كلام خبير ! وعلينا الاستماع والانصات ! واذا حضر الماء بطل التيمم ! تحياتي استاذ ابو شفيق ! اقصد الاستاذ ابو عارف

السلام عليكم ارى ان الموضوع لم يلاقي اهتمام او ردود لمتابعه او للاستمرار به.... لذلك لن نقوم باستكمال الموضوع والتصاميم وشكرا ....

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

ضع هذا الكود فى وحدة نمطية Public Function closeIfOpen() As Boolean Dim objWINMGMTS As Object Dim objApps As Object Dim objApp As Object Set objWINMGMTS = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2") Set objApps = objWINMGMTS.ExecQuery("select * from win32_process where name='osk.exe'") For Each objApp In objApps objApp.Terminate Next End Function وقم بعمل استدعاء لها فى احدث مثلا عند النقر لاى زر Call closeIfOpen

السلام عليكم ورحمة الله وبركاته أخي الكريم ..الأعضاء في المنتدى لا يبخلون على أحد ، ولا ينتظرون مقابلاً مادياً ، ولا يتقاضون أجراً .. إنما كل يجود بما عنده ، من علم أو وقت .. فلا تستعجل .. وأكرر فلا تستعجل .. ولا تعتقد أنك بقولك " وينكم يا مبرمجين ؟ " أنك ستستنفرهم ، بالعكس ، لقد هممت ألا أجيب على طلبك ... ولكن خشيت أن أكون ممن يكتمون العلم فبالله عليكم إخواني رفقاً بإخوانكم .. رفقاً بإخوانكم الذي يقدمون المساعدة .. تفضل الملف المرفق .. فيه زري أمر أحدهما لبدء عملية الترحيل ، ويبدأ بعدها الترحيل كل 10 ثواني - بالطبع يمكنك تغيير الوقت كما تشاء - ، والزر الآخر لإيقاف عملية الترحيل .. أي إيقاف العداد .. أرجو أن يكون هذا هو المطلوب Transfer Data Every 10 Seconds.rar

أخي الحبيب ارفق ملفك للعمل عليه . واعذرني لضيق وقتي حاليا حيث أنني مشغول في أعمال الكنترول Islam Lover.rar

السلام عليكم شاهد المرفق 2003 فئات المبلغ.rar