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

ايه ياحبيبي ياغالي الموضوع مش مستاهل شراء وانت عارف كويس المصريين بيسلكوا دايما جرب المرفق دا وقولي رايك في منه كتير بس اللي يدور المكتبات دي موجودة من زمن BankCode.rar

ترقيم تلقائي يتجدد مع بداية كل سنة على النحو التالي 1300001 1300002 1300003 1400001 1400002 وهكذا ................. باعتبار الرقم 13 ، 14 هو السنة والترقيم لاشك سيكون تبعا للسنة الحالية Private Sub Form_BeforeInsert(Cancel As Integer) On Error Resume Next Dim xLast, xNext As Integer Dim prtyr, prtTxt As Integer prtyr = Right(DatePart("yyyy", Date), 2) prtTxt = Left(DMax("ID", "tbl1"), 2) xLast = DMax("ID", "tbl1", prtTxt = prtyr) If IsNull(xLast) Then xNext = 1 Else xNext = Val(Mid(xLast, 3, 5)) + 1 End If Me!ID = prtyr & Format(xNext, "00000") End Sub ترقيم تلقائي جديد كل سنة.rar

السلام عليكم اعتقد مهم ان اعطيكم مثال على Me.Painting ، فالتوضيح في الرابط التالي يحتاج الى توضيح http://www.officena.net/ib/topic/67464-المساعدة-في-فتح-صورة-من-listbox/?do=findComment&comment=438833 النموذج Form1 ، كل ثانية ، اللون الاصفر ينزل الى الحقل التالي (اي بمعنى ان النموذج يجدد شكل النموذج باستمرار ، وعليه نرى الالوان تنتقل من حقل الى آخر): الكود: Function Change_Colors(F) Me(F).BackColor = RGB(225, 225, 0) 'yellow Me(F) = F DoEvents PauseTime = 1 ' Set duration. Start = Timer ' Set start time. Do While Timer < Start + PauseTime DoEvents ' Yield to other processes. Loop Me(F).BackColor = RGB(255, 255, 255) 'white Me(F) = "" End Function Private Sub cmd_Start_Coloring_Click() Call Change_Colors("q1") Call Change_Colors("q2") Call Change_Colors("q3") Call Change_Colors("q4") Call Change_Colors("q6") Call Change_Colors("q7") End Sub . والنتيجة: . اما النموذج Form2 ، فهو نسخة من النموذج السابق Form1 ، إلا اني طلبت في الكود ان: اللون الاصفر يلون الحقل الاول والثاني ، ثم اعطيت الامر بعدم تجديد شكل النموذج بالامر Me.Painting=False فاللون الاصفر ظل على الحقل الثاني للنموذج ، بينما الكود استمر في عمله في تلوين الحقل الثالث والرابع ، ولكن دون ان يُظهر لنا النتيجة على النموذج ، ثم اعطيت الامر Me.Painting=True ، فاللون الاصفر اختفى من الحقل الثاني ، وظهر لآخر حقلين ، والكود هو: Function Change_Colors(F) Me(F).BackColor = RGB(225, 225, 0) 'yellow Me(F) = F DoEvents PauseTime = 1 ' Set duration. Start = Timer ' Set start time. Do While Timer < Start + PauseTime DoEvents ' Yield to other processes. Loop Me(F).BackColor = RGB(255, 255, 255) 'white Me(F) = "" End Function Private Sub cmd_Start_Coloring_Click() Call Change_Colors("q1") Call Change_Colors("q2") Me.Painting = False Call Change_Colors("q3") Call Change_Colors("q4") Me.Painting = True Call Change_Colors("q6") Call Change_Colors("q7") End Sub . والنتيجة: . طيب ، ما الفائدة عمليا من هذا الكود؟ انا استخدمت هذا الامر مرات جدا قليلة في برامجي ، والبرنامج اعلاه (في تغيير اسم الملف) هو احدهم ، اما البرنامج الآخر فهو: برنامج فيه آلاف السجلات ، وهناك صور للسجلات ، فكنت اريد ان اعرض النموذج بطريقة معينة ، بحيث باختيار اسم الموظف تصل الى معلوماته ، ولكني اردت ان اسمح لهم ان يروا بقية السجلات ايضا ، فالاكسس كان يعرض اول سجل وصورة ، ثم ينتقل الى السجل المطلوب ، وانا لم ارد للمستخدم ان يرى اول سجل وصورته ، وانما اردته ان يرى سجل وصورة الموظف الذي تم اختياره ، فاستخدمت هذه الطريقة في اخفاء السجل الاول وصورته (بعدم تجديد الشاشة) ، وعندما حان موعد ظهور السجل المطلوب وصورته ، اعطيت الامر بإظهار وتجديد شاشة الاكسس ، والنتيجة كانت مرضية لي جعفر 297.Me.Paint.accdb.zip

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

السلام عليكم إخواني الكرام أثناء تجوالي في مواقع الانترنت وجدت برنامج اسمه VBA Time Saver Kit فكرة البرنامج أنه يقوم بتخزين أكواد الـ VBA .. ويمكن البحث من خلاله بسهولة عن الكود المطلوب .. أعتقد أنه يمكن أن يكون نواة لمكتبة كبيرة نساهم جميعاً في إثراء تلك المكتبة .. لمن لديه خبرة في التعامل مع مواقع الانترنت والشراء من خلالها ويستطيع أن يقوم بشراء البرنامج حوالي 15 دولار فليتقدم ويتبرع إذا كان بإمكانه وبعد الشراء طبعاً عارفين ..كل الوطن العربي هيستخدم البرنامج اللي هيتم شرائه ..بس خلاص تقبلوا وافر تقديري واحترامي

السلام عليكم ورحمة الله تعالى وبركاته واجهت مشكلة كبيرة عند حساب الايام بين تاريخين تاريخ البدء وتاريخ الانتهاء على سبيل المثال وكان ما يهمنى هو عدم احتساب الجمعة والسبت ضمن هذين التاريخين على اعتبار انهم عطلة اسبوعية ثم خطر ببالى كذلك عدم احتساب الاعياد والمناسبات الرسمية بحثت وظللت ابحث وسهرت ولم انم منذ الأمس بسبب هذه المعضلة ولكن لم اجد اى حل فى اى منتدى حتى تفضل على الاستاذ ابو خليل جزاه الله عنا كل الخير ان شاء الله ولكن بصراحة هذا الحل لم يرضى طموحى فذهبت للبحث مرة اخرىووجدت فى موقع مايكروسوفت هذا الحل الذى أحدث خطأ فنجم عنه خلل فى الحسابات وحاولت فهم الية العمل وظللت اجرب واحاول وأخيرا بفضل الله سبحانه وتعالى الذى هدانا لهذا وما كنا لنهتدى لولا ان هدانا الله عزوجل توصلت لحل وقمت بتجربته مرار وتكرارا وبعد أن تأكدت من صحة ودقة معالجة البيانات قررت ان ارفعه على هذا الصرح الشامخ ملاحظة يمكن الاستفاده من هذا المرفق فى الاتى 1- حساب ايام العمل الفعليه بدون ايام الاجازات الرسمية والعطلة الاسبوعية --- العطلة الأسبوعية بالنسبه لى انا كانت الجمعهة والسبت ممكن تعديلها ☺ 2- حساب الاجازة التى تخصم من الرصيد فيستثنى منها ايام الاجازات الرسمية والعطل الاسبوعية كذلك للعلم تعدل بيانات الاجازات الرسمية والتواريخ من خلال القاعدة طبقا لكل دولة حتى لا يتم احتساب هذه التواريخ أحبكم فى الله وانتظر ردكم بعد التجربة ActualDaysCalcult.rar

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

اتفضلوا ملفين على الاكسيس اطلعوا عليهم لعلهم ينفعونا باذن الله فى الفكره دوال مايكروسوفت أكسس MS Access Functions.rar هذه بعض الأوامر في الأكسس.rar

أخي وحبيبي في الله محمد صالح أين أنت معلمي ..؟ اشتقنا لوجودك فيما بيننا .. مفتقدينك والله ومفتقدين حلولك الجميلة والرائعة لعل غيابك عنا خير تقبل وافر تقديري واحترامي

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

ارغى ياعم الامور ابو البراء يشاور بس وانا اعمله برنامج مخصوص يارب ما يشبط في الكلمة

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

أخي الكريم يرجى تغيير اسم الظهور للغة العربية ليعبر عن شخصكم الكريم لمعرفة التفاصيل قم بالإطلاع على موضوع التوجيهات في الموضوعات المثبتة في صدر المنتدى أخي الحبيب سليم بارك الله فيك وجزاك الله كل خير .. كود أكثر من رائع وسريع جداً جرب الكود التالي (هو غريب شوية لكن يؤدي الغرض !! الغرابة من إن السطر مكرر مرتين ..افتكاسات ياسر مع التهييس) Sub DeleteEmptyRowsAndColumns() Cells.SpecialCells(xlCellTypeBlanks).Delete Cells.SpecialCells(xlCellTypeBlanks).Delete End Sub تقبل وافر تقديري واحترامي

مكتبة مصممة بالفيجوال بيسك دوت نت Code Library 2009.rar

جرب هذا الكود Sub DeleteEmptyRowsAndColumns() x = ActiveSheet.UsedRange.Row - 1 y = ActiveSheet.UsedRange.Rows.Count LastRow = x + y Application.ScreenUpdating = False For r = LastRow To 1 Step -1 If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete Next r m = ActiveSheet.UsedRange.Column - 1 n = ActiveSheet.UsedRange.Columns.Count LastColumn = m + n For c = LastColumn To 1 Step -1 If Application.CountA(Columns(c)) = 0 Then Columns(c).Delete Next c Application.ScreenUpdating = True End Sub

تفضل هذا الملف قم بفك ضغطة وضعه في system32 داخل الويندوز او ضعه بجانب البرنامج وقم بتشغيله كما قال اخي الغالي عبد العزيز في وضع كمسئول RICHTX32.rar

السلام عليكم استاذى / زيزو العجوز .. حل متميز ..جزاك الله خيراً استاذى / ياسر العربى .. فكرة متميزة ..جزاك الله خيراً اخى الكريم .. اليك احد طرق الحل بالاكواد Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("L4:M4")) Is Nothing Then Dim LR As Integer, cl As Range, c As Range, cll As Range LR = Cells(Rows.Count, 4).End(xlUp).Row Set cl = Range("B3:B" & LR).Find([L4]) Range("O4") = Cells(cl.Row, 3) For Each c In Range("D3:D" & LR) If c = Range("M4") Then Set cll = Range("E2:I2").Find([O4]) Range("Q4") = Cells(c.Row, cll.Column) End If Next End If End Sub اليك المرفق اسعار متعدده.rar

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

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

اخى الكريم تحدثت عن الفترة الزمنية بين العمليات ولم تذكر ما مدى تأثير ذلك على النتائج ..جرب المرفق وابدى ملاحظاتك .. استخدام ;0)MAX لظهور صفر بدلاً من القيمة السالبة كشف حساب بالرصيد المتحرك(2).zip

السلام عليكم ورحمة الله اليك الحل باذن الله القوائم الاسمية.rar

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

بعد اذن اخي الغالي زيزو لاثراء الموضوع تفضل الحل بطريقة اخرى اسعار متعدده.rar

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

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

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

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

وعليكم السلام اليك هذاالكود من احد برامجي: ونفترض ان اسم الحقل (سواء في الاستعلام او في النموذج) strText ، فكود تغيير الاسم يكون: في النموذج Me.strText = Characters_Windows_Refuse (Me.strText) في الاستعلام A: Characters_Windows_Refuse ([strText]) و الوحدة النمطية Function Characters_Windows_Refuse(str_Name As String) As String 'check if the file name is correct, 'and it does not incluse the characters windows refuse 'usage: 'Me.strText = Characters_Windows_Refuse (Me.strText) ' Dim Correct_To As String Correct_To = "-" str_Name = Replace(str_Name, "\", Correct_To) str_Name = Replace(str_Name, "/", Correct_To) str_Name = Replace(str_Name, ":", Correct_To) str_Name = Replace(str_Name, "*", Correct_To) str_Name = Replace(str_Name, "?", Correct_To) str_Name = Replace(str_Name, Chr(34), Correct_To) str_Name = Replace(str_Name, "<", Correct_To) str_Name = Replace(str_Name, ">", Correct_To) str_Name = Replace(str_Name, "|", Correct_To) 'return this value to the field Characters_Windows_Refuse = str_Name End Function جعفر

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

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

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

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

الطريقة التي مشت معي هي نفس الطريقة التي قال فيها الاستاذ أبو عيد وهي 1 قمت بوضع مشاركة للمجلد الذي في القرص D ( وهو المجلد الذي نشير الية بالربط ) 2 ثم قمت بربط كلمة test الموجودة في الخلية b3 مع المجلد الذي اسمة test في القرص دي طريقة الربط موجودة في الكود بقية الشرح موجود في داخل الملف المرفق -------------------------------------------- شكراً لكم جميعاً استاتذي الكرام . ------------------------------------- أحمد الفلاحجى ياسر خليل أبو البراء ياسر العربى أبوعيد nasersaeed أبو قاسم --------------------------- test.rar

ما النت فريم وورك اصدارات ممكن بيعتمد على اصدار معين هتأكد من المكتبة واشوفلك مشكلتها باذن الله وعلى ما اشوفها شوف المكتبة دي بالمرة انا بلاقيهم على الجهاز مش بنزلهم كلها كنت منزلها ايام شغل الفيجوال ببيسك 6 والدوت نت المهم كله بيقوم بنفس الغرض وهو حفظ الاكواد Code Library.rar

جزاك الله خير على التوضيح

اخوانى كثيرا منا يرث ملفات منقولة من اخرين بها اسطر فارغة قد لا يريدها هو اختار استبدال replace اكتب فى خانة البحث عن ^P^P فى خانة استبدال ب ^P على فكرة ^ للوصول لها اضغط shift+6 راعى الترتيب ^ قبل p دمتم بخير سعد عابد

جزاك الله خير

اخي الغالي -3 هذه بالمعادلة lookup لاظهار رقم العمود الموجود به التصنيف دا من الشيت عموما يعني ممكن يطلع مثلا العمود رقم 9 اللي هي pr4 طيب نشوف معادلتنا الvlookup فيها كام عمود وبدايتها منين هنلاقيها تبدأ من العمود رقم 4 وتحتوي على 6 اعمدة فقط نحلها ازاي نشيل اول 3 اعمدة من الرقم اللي هيظهر اللي هو 9 هيبقي6 ودا اخر عمود في الدالة vlookup عشان كدا خصمت 3 من عدد الاعمدة ياريت تكون وضحت الصورة

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

يمكن استعمال هذه المعادلة البسيطة (اختر منها النطاق المناسب) =SUMPRODUCT(--ISNUMBER(SIGN($A$1:$A$8)),$A$1:$A$8)

اخي الغالي ياريت مرفق ملف كمثال توضيحي للمطلوب يكون افضل

السلام عليكم الموضوع بسييييط للغاية أخي العزيز المشكلة تكمن في المجلد الموجود في D هذا المجلد يجب أن يوضع في مجلد الشبكة (وليس في D )

??????????????????????? انتظر ردك اخى بالتوفيق

ذكرتني بأيام زمان والايام اللي تبعته ما كنت ادري انك تشوف المستخبري كمان ، لازم اخلي بالي المرات الجاية الكود اصبح: Option Compare Database Private Sub clase_form_Click() DoCmd.Close End Sub Private Sub cmd_open_a_File_Click() 'open the file outside the program Application.FollowHyperlink Me.lst_Files.Tag & Me.lst_Files.ItemData(Me.lst_Files.ListIndex) End Sub Private Sub cmd_Rename_Click() newpathANDname1 = InputBox("Please insert a new name") If Len(newpathANDname1 & "") = 0 Then Exit Sub newpathANDname = Me.lst_Files.Tag & newpathANDname1 & ".jpg" oldpathANDname = Me.lst_Files.Tag & Me.lst_Files.ItemData(Me.lst_Files.ListIndex) 'make a copy of the fie, with the new name FileCopy oldpathANDname, newpathANDname 'select another file in the listbox, so that this file is no longer in-use For i = 0 To lst_Files.ListCount - 1 If lst_Files.Column(0, i) <> newpathANDname1 Then Me.lst_Files.Selected(i) = True Exit For End If Next i 'now delete the old file name Kill oldpathANDname 'don't refresh the Form Me.Painting = False 'read the folder files Call Form_Current 'select the same file name For i = 0 To lst_Files.ListCount - 1 If lst_Files.Column(0, i) = newpathANDname1 Then Me.lst_Files.Selected(i) = True Exit For End If Next i 'refresh the Form Me.Painting = True End Sub Private Sub Form_Current() Dim imagepath As String '1 imagepath = Application.CodeProject.Path '2 imagepath = imagepath & "\Photo\" 'if the photo Dir dose not exist, creat it If Dir(imagepath, vbDirectory) = "" Then MkDir imagepath End If '3 imagepath = imagepath & [E_number] & "\" 'if the [code] Dir dose not exist, creat it If Dir(imagepath, vbDirectory) = "" Then MkDir imagepath End If 'Place the imagepath in the listbox tag Me.lst_Files.Tag = imagepath 'cleaning up Me.lst_Files.RowSourceType = "Value List" Me.lst_Files.RowSource = "" Me.imageframe.Picture = "" 'Directory file to the listbox strFile = Dir(imagepath & "*.*") Do Until strFile = "" Me.lst_Files.AddItem Item:=strFile strFile = Dir() Loop End Sub Private Sub lst_Files_Click() 'show the picture Me.imageframe.Picture = Me.lst_Files.Tag & Me.lst_Files End Sub جعفر 296.imageListBox.accdb.zip

وعليكم السلام ابش رايك في Enhanced Msgbox (هو اصلا نموذج ، ولكن معمول خصيصا لعمل Msgbox ) ، وجاهز للتحميل المجاني هذه بعض الاشكال والالوان التي تستطيع ان تعملها ، وطبعا اللغة كذلك . وفي نسخته العاشرة هذا رابط الموقع ، وجميل النظر الى ملاحظات القرّاء: http://blog.nkadesign.com/2008/ms-access-enhanced-message-box-replacement/ ولتحميل البرنامج: http://blog.nkadesign.com/wp-content/uploads/2008/05/EnhancedMsgBoxv1.10.zip جعفر

مثال رقم 3 :- فى المثال رقم 2 كان الشرح على نفس الصوره السابقه فورم فى مرحلة التصميم وصممت عليه Frame والفريم لا يوجد به اى عناصر تحكم تم تصميمها وكان المثال برقم 2 انى اعمل كود عند فتح الفورم يكون هناك عدد 10 صفوف من العناصر كل صف به ليبل وتكست بوكس وكمبوبوكس المثال بتاعنا اليومعايز اعرف ازاى اضيف عناصر تحكم اثناء فتح الفورم من شيت اكسيل وعدد الصفوف بالشيت غير معروف عددها فى زياده او نقصان شاهد الصوره هتعرف اكتر المثال بتاعنا بكل بساطه نفس الكود اللى بالمثال 2 مع تعديلات فنيه بسيطه جدا دا كان الكود اللى بالمثال 2 Private Sub UserForm_Initialize() Dim Top As Integer Dim i As Integer Top = 5 For i = 1 To 10 With Me.Frame1.Controls.Add("Forms.Combobox.1", "Combobox" & i) .Left = 20 .Top = Top .Height = 40 .Width = 150 .BackColor = &HFFFFC0 .TextAlign = fmTextAlignCenter .FontSize = 20 .Font.Bold = True Dim a As Variant a = Array("ناجح", "راسب") .List = a End With With Me.Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i) .Left = 180 .Top = Top .Height = 40 .Width = 150 .TextAlign = 2 .FontSize = 20 .Font.Bold = True .BackColor = &HC0FFFF End With With Me.Frame1.Controls.Add("Forms.Label.1", "Label" & i) .Left = 340 .Top = Top .Height = 40 .Width = 150 .SpecialEffect = fmSpecialEffectEtched .TextAlign = 2 .FontSize = 24 .Font.Bold = True .BackColor = 8454016 .Caption = "الصقر" & i End With Top = Top + 40 Next Me.Frame1.ScrollHeight = Top End Sub ايه المطلوب تعديله بالكود لكى يتناسب مع المطلوب بتاعنا رفع الخلايا من الشيت الى الفريم المثال كان على ان عدد الصفوف 10 لذالك استخدمنا الحلقه For next كالتالى For i = 1 To 10 فدلوقتى انا عايز اجيب الخلايا بالشيت رقم 1 النطاق من A2 الى اخر صف هيكون به اخر طالب اذن بداية الحلقه هى اول صف بالجدول وهو الخليه A2 ورقم الصف لها هو 2 اذن الحلقه هتبدأ من رقم 2 الى ؟ الى اخر صف به بيانات فى العمود A اذن لازم احدد اخر صف به بيانات من خلال السطر التالى واحنا شرحناه قبل كدا lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row عملت متغير واسمه Lr وتقدر تسميه اى اسم كيفما شئت وقلت ان المتغير Lr يساوى كتبت اسم الشيت المراد العمل عليه واستخدمت Cells لتحديد عدد الخلايا الممتلئه بالبيانات فى العمود 1 كدا انا عرفت الحلقه من اين تبدأ واين تنتهى ( تبدأ من الصف 2 الى اخر صف به بيانات ) For i = 2 To lr شاهد الكود بعد تعديل الحلقه For Private Sub UserForm_Initialize() Dim Top As Integer Dim i As Integer lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row Top = 5 For i = 2 To lr With Me.Frame1.Controls.Add("Forms.Combobox.1", "Combobox" & i) .Left = 20 .Top = Top .Height = 40 .Width = 150 .BackColor = &HFFFFC0 .TextAlign = fmTextAlignCenter .FontSize = 20 .Font.Bold = True Dim a As Variant a = Array("ناجح", "راسب") .List = a .Text = Sheet1.Cells(i, 3).Text End With With Me.Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i) .Left = 180 .Top = Top .Height = 40 .Width = 150 .TextAlign = 2 .FontSize = 20 .Font.Bold = True .BackColor = &HC0FFFF .Text = Sheet1.Cells(i, 2).Text End With With Me.Frame1.Controls.Add("Forms.Label.1", "Label" & i) .Left = 340 .Top = Top .Height = 40 .Width = 150 .SpecialEffect = fmSpecialEffectEtched .TextAlign = 2 .FontSize = 24 .Font.Bold = True .BackColor = 8454016 .Caption = Sheet1.Cells(i, 1).Text End With Top = Top + 40 Next Me.Frame1.ScrollHeight = Top End Sub اللى مركز معايا هيلاقى 1- تم تعديل بداية ونهاية الحلقه For 2- فى سطر تم اضافته فى خصائص كل عنصر فى عنصر الكمبوبوكس تم اضافه السطر التالى .Text = Sheet1.Cells(i, 3).Text قيمة الكمبوبوكس هى كتبت اسم الشيت وهو بمثالنا الشيت 1 ثم الخلية المطلوبه Cells عباره عن (رقم العمود, رقم الصف)Cells ( Cells( i , 3 i هنا هى رقم الصف اللى هيتغير كل مره بالحلقه For والعمود هو رقم 3 الخاص بالحاله --------------------------------- فى عنصر التكست بوكستم اضافه السطر التالى .Text = Sheet1.Cells(i, 2).Text نفس الكمبوبوكس ولكن تم تغيير رقم العمود هو 2 الخاص بالدرجه ---------------------------------- فى عنصر الليبل تم اضافه السطر التالى .Caption = Sheet1.Cells(i, 1).Text نفس الكمبوبوكس والتكست بوكس ولكن تم تغيير رقم العمود هو 1 الخاص باسم الطالب ----------------------------------------------------------------------------------------------------------------------- ملحوظه اخيره لمن يريد درجة الاحترافيه فى الكود لما كنا بنعمل خصائص العنصر كان الخاصيه Left & Top & Width& Height لكل عنصر كان بيتم كتابتهم بالشكل التالى كلا منهم على حد فى سطر مختلف على سبيل المثال خصائص التكست بوكس With Me.Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i) .Left = 180 .Top = Top .Height = 40 .Width = 150 .TextAlign = 2 .FontSize = 20 .Font.Bold = True .BackColor = &HC0FFFF .Text = Sheet1.Cells(i, 2).Text End With ممكن اكتب الاربع خصائص فى سطر واحد من خلال Move القاعدة الخاصه بــ Move Move Left, Top, Width, Height. ويكون شكل الكود كالتالى بالخصائص With Me.Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i) .Move 180, Top, 150, 40 .TextAlign = 2 .FontSize = 20 .Font.Bold = True .BackColor = &HC0FFFF .Text = Sheet1.Cells(i, 2).Text End With تم استبدال الاربع صفوف بسطر واحد من خلال Move -------------------------------------------------------------------------------------------------------- جرب الكود بنفسك هتثبت المعلومه اكتر الى لقاء اخر من حلقات سلسلة علمنى كيف اصطاد ان شاء الله هيكون عن كيفية التحكم فى العناصر الموجوده داخل الفريم سوء كانت مصممه اثناء عملية التصميم او تم انشائها بكود انتظرونا تقبلوا تحياتى

اعزائي اقدم لكم كيفية حساب الفرق بين تاريخين مع الوقت وبالايام والساعات والدقائق !! الطريقة بالاستعلام qr1 SELECT tbl_time.id, tbl_time.Sdate, tbl_time.Stime, tbl_time.Edate, tbl_time.Etime, CStr((DateDiff("n",([Sdate] & Chr(32) & [Stime]),([Edate] & Chr(32) & [Etime]))\60)\24) & " days;" & CStr((DateDiff("n",([Sdate] & Chr(32) & [Stime]),([Edate] & Chr(32) & [Etime]))/60) Mod 24) & " hours and " & CStr(DateDiff("n",([Sdate] & Chr(32) & [Stime]),([Edate] & Chr(32) & [Etime])) Mod 60) & " minutes" AS Ramhan FROM tbl_time; ولكم خالص تحياتي حساب الوقت.rar

الطبيعي هو أنك عند إدراجك للتاريخ الأول لا يتم الحساب وبمجرد تغييرك للتاريخ الثاني يتم الحساب على التاريخ الأول وعند خروجك من تغيير التاريخ الثاني يتم الحساب على التاريخين

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

أخي يحيى حسين اسمح لي بقليل من التعليق وهو أنك اعتمدت في الأكواد السابقة على فراغ الخلية الأولى من كل صف حتى يتم حذفه فمن الممكن أن تكون الخلية الأولى فارغة وباقي الخلايا مكتوب فيه أو العكس وبالفعل تم مناقشة هذا الموضوع في منتدى آخر وعرض أحد الإخوة هذه الدالة التي تقوم بحذف الصفوف الفارغة Sub deleteEmptyRows() Dim LastRow As Integer Dim MyRow As Integer Application.ScreenUpdating = False LastRow = ActiveSheet.UsedRange.Row - 1 + _ ActiveSheet.UsedRange.Rows.Count For MyRow = LastRow To 1 Step -1 If Application.CountA(Rows(MyRow)) = 0 Then Rows(MyRow).delete Next MyRow Application.ScreenUpdating = True End Sub ولكني لاحظت أنها تقوم بحذف الأسطر الفارغة صفا صفا وكنت قد بحثت في فترة سابقة على النت فوجدت هذه الدالة التي تعتمد على حذف المناطق الفارغة مما يزيد سرعة عملية الحذف Sub DeleteBlankRows() Set myrange = Range("B4:I31") Set blanks = myrange.SpecialCells(xlCellTypeBlanks) For Each area In blanks.Areas If area.Columns.Count = myrange.Columns.Count Then area.EntireRow.Delete End If Next area End Sub وهذه دالة من تصميمي بناء على الدالة الأولى مع بعض التعديلات Sub Mas_DelBlankRows() On Error Resume Next Dim n As Integer For n = 1 To ActiveSheet.UsedRange.SpecialCells(4).Areas.Count If ActiveSheet.UsedRange.SpecialCells(4).Areas(n).Columns.Count = ActiveSheet.UsedRange.Columns.Count Then ActiveSheet.UsedRange.SpecialCells(4).Areas(n).EntireRow.Delete Next n End Sub وفي الكودين السابقين يتم تحديد الصف الفارغ بناء على عدم وجود بيانات في أي خلية من خلاياه وليس فقط الخلية الأولى وبالله التوفيق أخوكم محمد صالح