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

تفضل تم تعديل الباسوورد DATA12.rar

تعديل بسيط بإضافة أزرار التنقل للاستعراض والتنقل Vote.mdb Vote.zip

هنا ، في نموذج frmlogin If (UserName = rst!User_Name) And (EncryptDecrypt(Password, UserName) = rst!Password) Then التعديل : If (UserName = rst!User_Name) And (EncryptDecrypt(rst!Password, UserName) = Me.Password) Then التفكير المنطقي يظهر الفرق

السلام عليكم اعتقد مهم ان اعطيكم مثال على 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

ليه انت ما سمعتش عن الموضوع ده : جعفر

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

تفضل التعديل اخي الكريم DATA12.mdb

هذا الحل يفترض عدم وجود أحرف أبجدية في الملف إلا في أسماء المواد الدراسية، ويفترض عدم وجود أرقام في أسماء المواد الدراسية. إن لم يصحّ أيّ من الافتراضين فلا تعتمد هذا الحل.‏ في مربع البحث والاستبدال، انسخ والصق ما يلي في خانة البحث:‏‏ ([ء-ْ]@[ ء-ْ]@ ) ثم انسخ والصق ما يلي في خانة الاستبدال:‏ ^p\1 ‫تأكد من تحديد "باستخدام أحرف البدل" (Use wildcards) بعد النقر على "المزيد" (More).‏ ‫بعد ذلك اضغط على "استبدال الكل" (Replace all).‏ احرص أن تجرّب الطريقة على نسخة من المستند.‏

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

ألف مبروك وبالتوفيق دائمًا بإذن الله

بل لى عظيم الشرف ان انقل عن اساذتى واخوانى العفو منكم انا اقل طويلب علم وسوف أظل دائما وأبدا اتعلم من كل اساتذتى العظماء واخوانى واحبابى

الملف لا يفتح

وعليكم السلام يا هندسة اتفضل ☺ بعد إذن استاذى الجليل ومعلمى القدير الاستاذى @د.كاف يار وبعد إذن الاستاذ الفاضل استاذ @ناقل اسمح لى انا اللى اكوون ناقل منك المره دى لان راح انقل فكرتك لكن بطريقتى وطبعا لان انا اللى فكرت فى المرفق اشتغل بمزاجى يا باش مهندس ملاحظة هامة : النموذج لا يظهر موضوعات استطلاعات الرأى لاى تاريخ قبل تاريخ اليوم الجدول tblVotingResources يتم اضافة موضوعات استطلاعات الراى به مع وضع تاريخ نهاية موعد ظهور الاستطلاع الجدول tblVotingHistory يتم اضافة الاستطلاع اليه حسب ال ID الخاص بالاسطلاع مع الـ ID الخاص بالمستخدم الذى قام بالتصويت او الاعجاب كما يتم حذف التصويت منه كذلك بنفس الالية Vote.mdb Vote.zip

وفيك بارك الله ابا احسان وللرجوع الى اخر نسخه رفعتها لك فان الكود الذى ارفقته هو لفتح النموذج المذكور فالنماذج كلها تبدا من اليسار frm واما التقارير فكلها تبدا من اليسار ب rpt ارفق الملف الذى ظهرت به الرساله للاطلاع

وعليكم السلام اخى الفاضل ابواحسان انت تقول تقرير وعليه يكون الكود لان الكود السابق لفتح نموذج DoCmd.OpenReport "frm_Items_Dates" بالتوفيق

الملف الذي رفعته لا يمكن تنزيله (Unavailable) لذلك اقترح تجربة هذا الملف Option Explicit Function Remove_int(Txt, k) Dim Salim_Match, n With CreateObject("VBScript.RegExp") .Global = True .Pattern = "(\d)" If .Test(Txt) Then Set Salim_Match = .Execute(Txt) If k >= Salim_Match.Count Then n = Salim_Match(Salim_Match.Count - 1).FirstIndex Remove_int = Mid(Txt, 1, n) Else n = Salim_Match(k).FirstIndex + 1 Remove_int = Mid(Txt, 1, n - 2) _ & Mid(Txt, n, Len(Txt)) End If Else Remove_int = "N/A" End If End With End Function '+++++++++++++++++++++++++++++++++ الملف مرفق Remove_Only_One_Number.xlsm

جرب المرفق معلومات فنية اتصالات.xlsm

نعم ، وتم مناقشة هذه النقطة في الرابط الذي ارفقته لك ، هنا في هذه المشاركة لأخونا @kha9009lid : جعفر

شكرا على التدقيق 🙂 ولو اني ما اعرف ليش يصير هذا ، ولكن استعمل هذا الكود الآن: Private Sub go_Click() Call tn_AfterUpdate End Sub Private Sub tn_AfterUpdate() On Error GoTo err_tn_AfterUpdate If Len(Me.tn & "") = 0 Or DCount("*", "qry_tbl2", "HNO =" & Me.tn) = 0 Then MsgBox "الرقم غير موجود" Else Me.Recordset.FindFirst "hno=" & Me.tn End If Exit_tn_AfterUpdate: Me.tn.SetFocus Me.tn = "" Exit Sub err_tn_AfterUpdate: If Err.Number = 3075 Then 'ignore Else MsgBox Err.Number & vbCrLf & Err, vbAbortRetryIgnore End If Resume Exit_tn_AfterUpdate End Sub جعفر

حياكم الله ، على الرحب والسعة 🙂 مباشرة وبالطريقة العادية ، لا ، ولكن يمكن هكذا : جعفر

Try This code Option Explicit Sub Hide_then_Print() Dim LR% With Sheets("موازنة 2020") LR = .Cells(Rows.Count, 1).End(3).Row .Rows("1:3").Hidden = False .PageSetup.PrintArea = _ .Range("A1:F" & LR).Address .PrintPreview ' <<<==== Change to .PrintOut .Rows("1:3").Hidden = True End With End Sub

شرح وافي متكامل ودقيق ومرجع مهم للمبرمج تكثر الحاجة اليه شكرا جزيلا استاذ جعفر ، جعله الله في موازين اعمالك .

الف مبروك ⚘

الف مبروك يا باشا

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

نسيت أنبهك لتعريف تنسيق/تحديد نوع الصناديق/المربعات لتجنب مشاكل التحويل وتجنب الحصول على نتائج غير متوقعة. PaymentDate, d1 , d2 تنسيق تاريخ و n1 تنسيق رقم.

الف مبروك الترقية للاستاذ محي الدين ابو البشر اتمنى لك التوفيق وطول العمر

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

تفضل التعديل اخي الكريم سيتم تنبيه المستخدم في حال الاستخدام وصل الى 100 مرة و للاستمرار يجب ادخال مفتاح الترخيص للاستمرار مفتاح الترخيص هو 123 تستطيع التعديل عليه DATA12.mdb

وعليكم السلام ورحمة الله وبركاته طريقة التحويل داخل الاكواد تجد VBA.Calendar= vbCalHijri قم بتغيرها الى VBA.Calendar= vbCalGreg والله اعلم الملف بعد التعديل Daily (1).xlsm

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

وعليكم السلام-بسيطة اجعل المعادلة بالخلية F42 بالجدول الأول هكذا , ويجب عليك تعميم هذه المعادلة على باقى الجداول -تفضل =IF(SUM(F9:F39)>26,26,SUM(F9:F39)) 1رواتب واجور2021 - يناير.xlsx

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

وعليكم السلام ... تجنباً لعدم اهدار واضاعة وقت الأساتذة وبما انه لا يمكن العمل على التخميت , فعليك برفع ملف مدعوم بشرح كافى عن المطلوب !!!! أو عليك بوضع هذا الكود بحدث ThisWorkBook وذلك على ان اسم الفورم لديك هو UserForm1 , ويمكنك تغيير هذا الإسم بما لديك Private Sub Workbook_Open() Application.Visible = False UserForm1.Show End Sub

وعليكم السلام-أهلاً بك فى المنتدى -يمكنك استخدام هذه المعادلة لحساب التأخير =IF($D10<$M$12,"",(D10-$M$12)) وهذه لحساب الإضافى =IF(F10=0,"",IF($E10<$M$13,0,$E10-$M$13)) وتم وضع المعادلات بالجدول الأول , فعليك بتعميم هذه المعادلات بباقى الجداول رواتب واجور2021 - يناير.xlsx

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

ضع هذا في حدث الفورم خاص لتعبئة تيكسبوكس53 اخر خلية العمود 1 sheet1 Private Sub UserForm_Initialize() Dim lr With Sheets("Sheet1") lr = .Cells(Rows.Count, 2).End(xlUp).Row TextBox53.Value = .Range("b" & lr).Offset(, -1) End With End Sub وهذا في حدث الشيت1 لادراج مسلسل Private Sub Worksheet_Change(ByVal Target As Range) Dim lr lr = Cells(Rows.Count, 2).End(3).Row If Intersect(Target, Range("a" & lr)) Is Nothing Then Range("a11:a" & lr).Formula = "=IF(B11="""","""",SUBTOTAL(103,$B$11:B11))" End If End Sub yousef (1).xlsb

الاكواد داخل فورم اضفته في ملفك yousef.xlsb

السلام عليكم ورحمة الله استخدم هذا الكود Sub Right_To_Left() Dim ws As Worksheet For Each ws In Worksheets ws.DisplayRightToLeft = True Next End Sub

عمل ممتاذ استاذي الفاضل بس للاسف لايعمل عندي يعطيني هذه الرسالة مع العلم اني اعمل علي اوفيس 2007

حياك الله أخوي رمهان زين الحمدلله طلّيت علينا انا كذلك كان عندي تجربة اخرى مع Echo ، وهي عند كتابة ملاحظات على Status Bar في اسفل النموذج ، وكذلك استخدمت بديل له ، وهو: DoEvents Call SysCmd(acSysCmdSetStatus, "HI THERE!!") DoEvents . و الامر DoEvents جدا مهم ، وهو لإخبار الكود بأن يعمل الامر هذا ، ويواصل العمل للخطوة التالية اما عن اغلاق المواضيع ، فانا اقوم بإغلاق مواضيعي ، وذلك بعد ان يسأل صاحب الموضوع سؤال لا علاقة له بالموضوع ، فأضطر عمل هذا حتى لا يتشعب الموضوع جعفر

أخي الفاضل المنار لم تستجب لمطلبي ..عموماً قمت بالعمل على ورقة عمل واحدة فقط ليطمئن قلبك أن الأمر ممكن .. قمت بالتغيير قليلا في ملف الـ Template الذي يعتبر بمثابة النموذج المراد العمل عليه إليك الملف التالي .. ويمكنك الإضافة إلى الكود بحيث يشمل أي بيانات .. اكتفيت بورقة العمل الأولي فقط Sub SplitWB() Dim WBK As Workbook Dim Cell As Range Dim strPath As String Dim I As Long, Arr Application.ScreenUpdating = False Application.DisplayAlerts = False Arr = ThisWorkbook.Sheets("Sheet1").Cells(1).CurrentRegion.Value For I = 2 To UBound(Arr, 1) strPath = ThisWorkbook.Path & "\" FileCopy strPath & "Template.xlsx", strPath & Arr(I, 2) & ".xlsx" Set WBK = Workbooks.Open(strPath & Arr(I, 2) & ".xlsx") With WBK With .Sheets("المعلومات الاساسية") ThisWorkbook.Activate .Range("B3").Resize(15, 1) = Application.Transpose(Array(ThisWorkbook.Sheets("Sheet1").Range(Cells(I, 2), Cells(I, 16)))) .Range("A19") = Arr(I, 17) .Range("A21") = Arr(I, 18) .Range("A23") = Arr(I, 19) End With .Close SaveChanges:=True End With Next I Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "تم بحمد الله .. قل سبحان الله وبحمده سبحان الله العظيم", vbInformation End Sub تقبل تحياتي Copy Workbook Template & Name It By Employee YasserKhalil.rar

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