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

وعليكم السلام أخي الكريم محمد سامر أهلاً بك في المنتدى ونورت بين إخوانك الرجاء التماس العذر لإخوانك فالجميع هنا لا يتأخر عن تقديم المساعدة ولكن حينما يتيسر الوقت لهم .. فالرجاء الصبر .. إليك خطوات الحل بالتنسيق الشرطي (وقد استخدمه الأخ سليم بمعادلة أخرى .. ولكني استخدمت معادلة أسهل في الفهم لك) وإليك الملف المطبق فيه الخطوات السابقة مع شرح لكيفية الاستفادة من الجدول المساعد لتفهم كيف تم الأمر Conditional Formatting Using OR Tutorial YasserKhalil Officena.rar

بسم الله الرحمن الرحيم هنا سيتم تجميع ما يخص اكسس وارتباطه بقواعد البيانات الاخرى Link Access with Sql Server 2012 تمت كتابته بواسطة ابو محمد تطوير نموذج التقييم للعمل اونلاين دون الحاجة الى ارسال ميل تمت كتابته بواسطة السيد جمال ربط قاعدة البيانات باستضافة على الشبكة والتحكم بها من اي مكان في العالم للسيد جمال http://www.officena.net/ib/index.php?showtopic=61514 تحويل قاعدة بيانات من اكسس الى SQL تمت كتابته بواسطة محمد أيمن استخراج اسم سيرفر SQL وتحديد قاعدة بيانات للارتباط بها تمت كتابته بواسطة محمد أيمن

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

اسلوبك في التخاطب راق جزاك الله خيرا

وما هو الحال اذا يكون القاعدة من نوع ACCDB ACCDE ؟ اليك هذا لكل انواع ACCDB ACCDE MDB MDE غیر ھذا السطر من الكود If (Split(Forms!FORM1!txtPath, ".")(1)) = "MDE" Then بـهذا If Right(Split(Forms!FORM1!txtPath, ".")(1),1) = "E" Then

وعليكم السلام اختي تفضلي: . . جعفر

حياك الله

تفضل 688.1.لازام نطوره - Copy.mdb.zip

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

لا ، ولهذا السبب اعطاك اخي شفان جواب على الطاير جعفر

تفضل وهذا الكود الاول Private Sub أمر20_Click() On Error GoTo error_Capture تابع15.Requery Dim rst As DAO.Recordset 'إيرادات iField = "إيرادات" mySQL = "Select [رقم السند]" mySQL = mySQL & " From السندات" mySQL = mySQL & " Where [نوع السند]='إيرادات'" mySQL = mySQL & " And التاريخ>=#" & Me.n1 & "#" mySQL = mySQL & " And التاريخ<=#" & Me.n2 & "#" mySQL = mySQL & " Order By [رقم السند]" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst rc = rst.RecordCount Me.Erad_From = rst![رقم السند] rst.MoveLast Me.Erad_To = rst![رقم السند] 'اجل iField = "اجل" mySQL = "Select [رقم السند]" mySQL = mySQL & " From السندات" mySQL = mySQL & " Where [نوع السند]='اجل'" mySQL = mySQL & " And التاريخ>=#" & Me.n1 & "#" mySQL = mySQL & " And التاريخ<=#" & Me.n2 & "#" mySQL = mySQL & " Order By [رقم السند]" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst rc = rst.RecordCount Me.Aajel_From = rst![رقم السند] rst.MoveLast Me.Aajel_To = rst![رقم السند] 'مصاريف iField = "مصاريف" mySQL = "Select [رقم السند]" mySQL = mySQL & " From السندات" mySQL = mySQL & " Where [نوع السند]='مصاريف'" mySQL = mySQL & " And التاريخ>=#" & Me.n1 & "#" mySQL = mySQL & " And التاريخ<=#" & Me.n2 & "#" mySQL = mySQL & " Order By [رقم السند]" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst rc = rst.RecordCount Me.Masareef_From = rst![رقم السند] rst.MoveLast Me.Masareef_To = rst![رقم السند] 'سداد iField = "سداد" mySQL = "Select [رقم السند]" mySQL = mySQL & " From السندات" mySQL = mySQL & " Where [نوع السند]='سداد'" mySQL = mySQL & " And التاريخ>=#" & Me.n1 & "#" mySQL = mySQL & " And التاريخ<=#" & Me.n2 & "#" mySQL = mySQL & " Order By [رقم السند]" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst rc = rst.RecordCount Me.Sadad_From = rst![رقم السند] rst.MoveLast Me.Sadad_To = rst![رقم السند] MsgBox "لا توجد سندات من نوع" & vbCrLf & msg Exit_error_Capture: rst.close: Set rst = Nothing Exit Sub error_Capture: If Err.Number = 3021 Then If InStr(msg, iField) = 0 Then msg = msg & iField & vbCrLf End If Resume Next ElseIf Err.Number = -2147352567 Then If InStr(msg, iField) = 0 Then msg = msg & iField & vbCrLf End If Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description Resume Exit_error_Capture End If End Sub وهذا كود قراءة النموذج الفرعي Private Sub cmd_Search2_Click() On Error GoTo error_Capture2 تابع15.Requery Dim rst As DAO.Recordset Dim rst2 As DAO.Recordset Set rst = Me.تابع15.Form.RecordsetClone 'إيرادات iField = "إيرادات" rst.Filter = "[نوع السند]='إيرادات'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Erad_From = rst2![رقم السند] rst2.MoveLast Me.Erad_To = rst2![رقم السند] 'اجل iField = "اجل" rst.Filter = "[نوع السند]='اجل'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Aajel_From = rst2![رقم السند] rst2.MoveLast Me.Aajel_To = rst2![رقم السند] 'مصاريف iField = "مصاريف" rst.Filter = "[نوع السند]='مصاريف'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Masareef_From = rst2![رقم السند] rst2.MoveLast Me.Masareef_To = rst2![رقم السند] 'سداد iField = "سداد" rst.Filter = "[نوع السند]='سداد'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Sadad_From = rst2![رقم السند] rst2.MoveLast Me.Sadad_To = rst2![رقم السند] MsgBox "لا توجد سندات من نوع" & vbCrLf & msg Exit_error_Capture2: rst.close: Set rst = Nothing rst2.close: Set rst2 = Nothing Exit Sub error_Capture2: If Err.Number = 3021 Then If InStr(msg, iField) = 0 Then msg = msg & iField & vbCrLf End If Resume Next ElseIf Err.Number = -2147352567 Then If InStr(msg, iField) = 0 Then msg = msg & iField & vbCrLf End If Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description Resume Exit_error_Capture2 End If End Sub جعفر 688.1.لازام نطوره - Copy.mdb.zip

و ما هو معيار الرسوب في المادة و هل ان حرف "غ" او "ح" له تأثير على النتيجة

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

اليك هذا DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdCopy DoCmd.GoToRecord , , acNewRec DoCmd.RunCommand acCmdPaste

نقدر نستخدم هذا في البداية نكتب اون ايرور ريسوم نيكست On Error Resume Next Dim sql As String Dim sql1 As String Dim x As Integer x = Len(Forms!FORM1![txtPath]) - Len(Replace(Forms!FORM1![txtPath], ".", "")) If (Split(Forms!FORM1!txtPath, ".")(1)) = "MDE" Then sql = "UPDATE TdateT INNER JOIN [system.MDE].Tdate ON TdateT.ID = Tdate.ID SET Tdate.demo = TdateT.demo" sql1 = "UPDATE TdateT INNER JOIN [system_admin.MDE].Tdate ON TdateT.ID = Tdate.ID SET Tdate.demo = TdateT.demo" Else sql = "UPDATE TdateT INNER JOIN [system.MDB].Tdate ON TdateT.ID = Tdate.ID SET Tdate.demo = TdateT.demo" sql1 = "UPDATE TdateT INNER JOIN [system_admin.MDB].Tdate ON TdateT.ID = Tdate.ID SET Tdate.demo = TdateT.demo" End If DoCmd.SetWarnings False DoCmd.RunSQL (sql) DoCmd.RunSQL (sql1) DoCmd.close acForm, Me.nAME لا فهمت مني خطأ .! انا قصدي ما اريد ان يتم تنزيل اي ملف الى جهاز بدون رخصتي اي يعني ما اريد تنزيل اي شيء فقد للتأكيد هل هناك تحديث ام لا بل اريد ان يتأكد واذا هناك التحديث بيعمل التنزيل

شرف لي ان اكون بينكم اخي الفاضل!!!! بارك الله فيك شرح وافي وكافي....جزيت كل خير

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

بعد إذن حبيبنا شيفان يمكن استعمال المعادلة الآتية DSum("Field", "Table", "Field > 0") حيث table اسم الجدول و field اسم الحقل الموجود به الأرقام

حسب مستطاعي انا حاضر لكن في الحقيقة انا لا اعرف ما هو اللازم علي ان افعل ... لأني بعد لا اعرف ماذا تريدون بالفعل ... وبحب العمل معك واذا تكون مستعد ان تشتعغل معنا هذا سيكون حافز لنا لكي نشتغل احسن ونقدم اتفضل اليك هذا الحل Dim sql As String Dim x As Integer x = Len(Forms!FORM1![txtPath]) - Len(Replace(Forms!FORM1![txtPath], ".", "")) If (Split(Forms!FORM1!txtPath, ".")(1)) = "MDE" Then sql = "UPDATE TdateT INNER JOIN [system.MDE].Tdate ON TdateT.ID = Tdate.ID SET Tdate.demo = TdateT.demo" Else sql = "UPDATE TdateT INNER JOIN [system.MDB].Tdate ON TdateT.ID = Tdate.ID SET Tdate.demo = TdateT.demo" End If DoCmd.SetWarnings False DoCmd.RunSQL (sql) DoCmd.close acForm, Me.nAME اليك القاعدة example.rar

معادلات عد في اكسس خلاصة مشاركة الأعضاء للاستفادة منها في المنتدى عد حقل رقمي متقدم: DCount("Sit_no";"الدور الثاني";"code_mnazel=" & [code_mnazel]) عد حقل رقمي بشرط حقل رقمي غائب: DCount("Sit_no";"الدور الثاني";"code_mnazel=" & [code_mnazel] & " and code_kyab>5") راسب: DCount("Sit_no";"الدور الثاني";"code_mnazel=" & [code_mnazel] & " and [code_natega]= 2") النسبة النسبة: IIf([حاضر]=0;0;[ناجح]/[حاضر]) عد حقل نصي بشرط حقل نصي متقدم عربي: Val(Nz(DCount("[Sit_no]";"الدور الثاني";"[mnazel]='" & [mnazel] & "'" &"and n_ar1='ARABIC'");0)) دمج: Val(Nz(DCount("[Sit_no]";"door_than_tasafy";"[mnazel]='" & [mnazel] & "'" & "and Damg_Status= 'YES'");0)) عد حقل رقمي بشرط حقل نصي متقدم علوم: Val(Nz(DCount("[Sit_no]";"الدور الثاني";"[School_code]=" & [School_code] & "" & "and n_sc1= 'OLOOM'");0)) متقدم: DCount("Sit_no";"الدور الثاني";"dept_code=" & [dept_code] & "and kind_edu = 'نظامي'") عد حقل رقمي بشرط حقل رقمي وحقل نصي غائب: DCount("Sit_no";"الدور الثاني";"dept_code=" & [dept_code] & " and code_kyab>5" & "and kind_edu = 'نظامي'") راسب: DCount("Sit_no";"الدور الثاني";"dept_code=" & [dept_code] & " and [code_natega]= 2" & "and kind_edu = 'نظامي'")

وعليكم السلام للأسف ما اتوصلت لعمل اللي تريده وبحثت في الانترنت كذلك ، ولم القى شيء كذلك الطريقة الوحيدة هي عمل جدول خاص للقائمة ، وبالتالي يمكنك استعمال Lookup في الجدول ، ولكن للعلم ، فاستخدام Lookup في الجداول غير مُحبّذ ، وبه عدة مشاكل ، وانت صادفت احد هذه المشاكل ، والطريقة الصحيحة هي عمل جدول خاص للقائمة ، وتستعمل القائمة في النموذج فقط. جعفر 689.Database1.accdb.zip

السلام عليكم شكرا أخوي ابو خليل ، فانت شجعتني ان اقوم بأخذ البيانات من النموذج الفرعي ، بدل زيارة الجدول ، وهذه ستكون اسرع الطرق عملت زر جديد ، ووضعت عليه هذا الكود: Private Sub cmd_Search2_Click() On Error GoTo error_Capture2 تابع15.Requery Dim rst As DAO.Recordset Dim rst2 As DAO.Recordset Set rst = Me.تابع15.Form.RecordsetClone 'إيرادات rst.Filter = "[نوع السند]='إيرادات'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Erad_From = rst2![رقم السند] rst2.MoveLast Me.Erad_To = rst2![رقم السند] 'اجل rst.Filter = "[نوع السند]='اجل'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Aajel_From = rst2![رقم السند] rst2.MoveLast Me.Aajel_To = rst2![رقم السند] 'مصاريف rst.Filter = "[نوع السند]='مصاريف'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Masareef_From = rst2![رقم السند] rst2.MoveLast Me.Masareef_To = rst2![رقم السند] 'سداد rst.Filter = "[نوع السند]='سداد'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Sadad_From = rst2![رقم السند] rst2.MoveLast Me.Sadad_To = rst2![رقم السند] Exit_error_Capture2: rst.close: Set rst = Nothing rst2.close: Set rst2 = Nothing Exit Sub error_Capture2: If Err.Number = 3021 Then MsgBox "لا توجد بيانات" Resume Exit_error_Capture2 Else Debug.Print Err.Number MsgBox Err.Number & vbCrLf & Err.Description End If End Sub جعفر 688.1.لازام نطوره - Copy.mdb.zip

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

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

Sub SortData() Dim LR As Long LR = Range("B" & Rows.Count).End(xlUp).Row Range("B9:C" & LR).Sort Key1:=Range("E9:E" & LR), Order1:=2, Key2:=Range("B9:B" & LR), Order2:=1, Header:=xlYes End Sub جزاك الله خيرا استاذ ياسر

طبعا سيكون هناك اكثر من طريقة لعمل المطلوب ، وانا اخترت الطريقة الاسهل لي تفضل الكود ، وقد اعدت مسمى الحقول من والى: Private Sub Form_Load() Me.Form.Caption = DLookup("[user]", "fbi") Dim rst As DAO.Recordset 'إيرادات mySQL = "Select [رقم السند]" mySQL = mySQL & " From السندات" mySQL = mySQL & " Where [نوع السند]='إيرادات'" mySQL = mySQL & " And التاريخ>=#" & Me.n1 & "#" mySQL = mySQL & " And التاريخ<=#" & Me.n2 & "#" mySQL = mySQL & " Order By [رقم السند]" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst RC = rst.RecordCount Me.Erad_From = rst![رقم السند] rst.MoveLast Me.Erad_To = rst![رقم السند] 'اجل mySQL = "Select [رقم السند]" mySQL = mySQL & " From السندات" mySQL = mySQL & " Where [نوع السند]='اجل'" mySQL = mySQL & " And التاريخ>=#" & Me.n1 & "#" mySQL = mySQL & " And التاريخ<=#" & Me.n2 & "#" mySQL = mySQL & " Order By [رقم السند]" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst RC = rst.RecordCount Me.Aajel_From = rst![رقم السند] rst.MoveLast Me.Aajel_To = rst![رقم السند] 'مصاريف mySQL = "Select [رقم السند]" mySQL = mySQL & " From السندات" mySQL = mySQL & " Where [نوع السند]='مصاريف'" mySQL = mySQL & " And التاريخ>=#" & Me.n1 & "#" mySQL = mySQL & " And التاريخ<=#" & Me.n2 & "#" mySQL = mySQL & " Order By [رقم السند]" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst RC = rst.RecordCount Me.Masareef_From = rst![رقم السند] rst.MoveLast Me.Masareef_To = rst![رقم السند] 'سداد mySQL = "Select [رقم السند]" mySQL = mySQL & " From السندات" mySQL = mySQL & " Where [نوع السند]='سداد'" mySQL = mySQL & " And التاريخ>=#" & Me.n1 & "#" mySQL = mySQL & " And التاريخ<=#" & Me.n2 & "#" mySQL = mySQL & " Order By [رقم السند]" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst RC = rst.RecordCount Me.Sadad_From = rst![رقم السند] rst.MoveLast Me.Sadad_To = rst![رقم السند] rst.close: Set rst = Nothing End Sub جعفر 688.لازام نطوره.mdb.zip أخي ابو عبد الله انا فكرت في طريقتك ، وبهذه الطريقة يجب علينا زيارة الجدول مرتين لكل نوع من انواع السجلات ، وعندنا اربع سجلات ، فمعناه عندنا 8 زيارات للجدول لأخذ القيم المطلوبة ، ولكنك تأتي بمعلومة واحدة كل مرة بينما الطريقة التي عملتها انا تقوم بـ 4 زيارات فقط ، ولكنها تأتي ببيانات اكثر من بياناتك ، ثم نصفيها والطريقة الافضل هي ان لا نقوم بأي زيارة للجدول ، فالبيانات موجودة في النموذج الفرعي ، وما علينا إلا ان نستخرجها منها جعفر

جرب هذا ووافنا بالنتائج هذا لأجل من سند رقم : (توضع بمصدر سجلات مربع النص - Control Source) =Nz(Dmin("SandNo";"SandatTable";"SandDate=#" & [Date] & "#");0) وهذا لأجل الى سند رقم: =Nz(Dmax("SandNo";"SandatTable";"SandDate=#" & [Date] & "#");0) طبعا مع تغير المسميات التالية لما يتفق مع تصميمكم sandNo = حقل رقم السند SandatTble = اسم الجدول الذى يحتوى على بيانات السندات SandDate = حقل تاريخ السند ملاحظة: 1- لأن المعيار تاريخ أضفنا هذه العلامة "#" وان كان المعيار نص سنستخدم بدلا منها هذه " ' " 2- يمكن استخدام أكثر من معيار باضافة "And" بين المعاير كتاريخ السند ونوع السند مثلا مع مراعات اختلاف نوع البيانات لكل معيار.

اليكم الملف تم تجربة بنجاح على اوفيس 2010 وعملت بها بعض اضافات و مسحت کود التأکید الانترنیت لأن ما اشتغل عندی حین عدم وجود الانترنیت وعگیت ھدول الرسائل و هذا هو الكود لنموذج التنزيل اوبديت للبرامج Option Compare Database Option Explicit Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef dwflags As Long, ByVal dwReserved As Long) As Long ' لتأکيد على اتصالك بالانترنيت Sub DownloadUpdate() Dim FileNum As Long Dim FileData() As Byte Dim MyFile As String Dim WHTTP As Object Dim str_folder As String Dim fShellRun As Object Set fShellRun = CreateObject("Wscript.Shell") On Error Resume Next Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5") If Err.Number <> 0 Then Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1") End If On Error GoTo 0 MyFile = "https://drive.google.com/drive/folders/0B9STtJY2DhAoQ1JET3F5N3NiMDQ" WHTTP.Open "GET", MyFile, False WHTTP.send FileData = WHTTP.ResponseBody Set WHTTP = Nothing If Dir("C:\MyDownloads", vbDirectory) = Empty Then MkDir "C:\MyDownloads" FileNum = FreeFile Open "C:\MyDownloads\Activation.mde" For Binary As #FileNum Put #FileNum, 1, FileData Close #FileNum DoCmd.OpenForm "frmrisale", acNormal Forms!FrmRisale.TimerInterval = 1000 Forms!FrmRisale!MyTxt.Caption = " [ C:\MyDownloads ]تم تنزيل ملف التفعيل في المسار التالي " Forms!FrmRisale!MyTxt.TopMargin = 100 str_folder = "C:\MyDownloads" ' folder to open Call Shell("explorer.exe " & str_folder, vbNormalFocus) 'DoCmd.Quit End Sub Private Sub Command0_Click() If GetIPAddress <> "127.0.0.1" Then Call DownloadUpdate Else DoCmd.OpenForm "frmrisale", acNormal Forms!FrmRisale.TimerInterval = 1000 Forms!FrmRisale!MyTxt.Caption = "انت غير متصل بالانترنيت .. تأكد من اتصالك بالانترنيت وحاول مجدداً " Forms!FrmRisale!MyTxt.TopMargin = 100 End If End Sub وهذا فانكشن للتأكيد على وجود الانترنيت Option Compare Database Option Explicit Public Const MIN_SOCKETS_REQD As Long = 1 Public Const WS_VERSION_REQD As Long = &H101 Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF& Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF& Public Const SOCKET_ERROR As Long = -1 Public Const WSADESCRIPTION_LEN = 257 Public Const WSASYS_STATUS_LEN = 129 Public Const MAX_WSADescription = 256 Public Const MAX_WSASYSStatus = 128 Public Type WSAData wVersion As Integer wHighVersion As Integer szDescription(0 To MAX_WSADescription) As Byte szSystemStatus(0 To MAX_WSASYSStatus) As Byte wMaxSockets As Integer wMaxUDPDG As Integer dwVendorInfo As Long End Type Type WSADataInfo wVersion As Integer wHighVersion As Integer szDescription As String * WSADESCRIPTION_LEN szSystemStatus As String * WSASYS_STATUS_LEN iMaxSockets As Integer iMaxUdpDg As Integer lpVendorInfo As String End Type Public Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLen As Integer hAddrList As Long End Type Declare Function WSAStartupInfo Lib "WSOCK32" Alias "WSAStartup" (ByVal wVersionRequested As Integer, lpWSADATA As WSADataInfo) As Long Declare Function WSACleanup Lib "WSOCK32" () As Long Declare Function WSAGetLastError Lib "WSOCK32" () As Long Declare Function WSAStartup Lib "WSOCK32" (ByVal wVersionRequired As Long, lpWSADATA As WSAData) As Long Declare Function gethostname Lib "WSOCK32" (ByVal szHost As String, ByVal dwHostLen As Long) As Long Declare Function gethostbyname Lib "WSOCK32" (ByVal szHost As String) As Long Declare Sub CopyMemoryIP Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) Public Function GetIPAddress() As String Dim sHostName As String * 256 Dim lpHost As Long Dim HOST As HOSTENT Dim dwIPAddr As Long Dim tmpIPAddr() As Byte Dim i As Integer Dim sIPAddr As String If Not SocketsInitialize() Then GetIPAddress = "" Exit Function End If If gethostname(sHostName, 256) = SOCKET_ERROR Then GetIPAddress = "" MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name." SocketsCleanup Exit Function End If sHostName = Trim$(sHostName) lpHost = gethostbyname(sHostName) If lpHost = 0 Then GetIPAddress = "" MsgBox "Windows Sockets are not responding. " & "Unable to successfully get Host Name." SocketsCleanup Exit Function End If CopyMemoryIP HOST, lpHost, Len(HOST) CopyMemoryIP dwIPAddr, HOST.hAddrList, 4 ReDim tmpIPAddr(1 To HOST.hLen) CopyMemoryIP tmpIPAddr(1), dwIPAddr, HOST.hLen For i = 1 To HOST.hLen sIPAddr = sIPAddr & tmpIPAddr(i) & "." Next GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1) SocketsCleanup End Function Public Function GetIPHostName() As String Dim sHostName As String * 256 If Not SocketsInitialize() Then GetIPHostName = "" Exit Function End If If gethostname(sHostName, 256) = SOCKET_ERROR Then GetIPHostName = "" MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name." SocketsCleanup Exit Function End If GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1) SocketsCleanup End Function Public Function HiByte(ByVal wParam As Integer) HiByte = wParam \ &H100 And &HFF& End Function Public Function LoByte(ByVal wParam As Integer) LoByte = wParam And &HFF& End Function Public Sub SocketsCleanup() Dim ERROR_SUCCESS If WSACleanup() <> ERROR_SUCCESS Then MsgBox "Socket error occurred in Cleanup." End If End Sub Public Function SocketsInitialize() As Boolean Dim WSAD As WSAData Dim sLoByte As String Dim sHiByte As String Dim ERROR_SUCCESS If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then MsgBox "The 32-bit Windows Socket is not responding." SocketsInitialize = False Exit Function End If If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then MsgBox "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets." SocketsInitialize = False Exit Function End If If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then sHiByte = CStr(HiByte(WSAD.wVersion)) sLoByte = CStr(LoByte(WSAD.wVersion)) MsgBox "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets." SocketsInitialize = False Exit Function End If SocketsInitialize = True End Function شکرا لك استاذ @sandanet على هذا الموضوع الرائع شكرا لك استاذنا @أبو عبدالله الحلوانى على المداخلة وشكرا لك استاذنا @jjafferr على مشاركتك .. لان مشاركتك يفرحنا ويعطينا الامل وهذا هو الملف بصيغة mdb تنزيل تحديث في رابط ثابت.rar

استاذي @أبو عبدالله الحلوانى اعتذر عن هذا الخطأ الغير مقصود فنسيت ان اضيف التالي Option Explicit Option Compare Database Dim strPing As String Dim strCommand As String Dim myIp والكود يعمل لدي بنجاح على اكسس 2007 وسأقوم بتجربته لاحقاً على اكسس 2003 ايضاً ان شاء الله

استاذ @sandanet عند تنفيذ الكود ظهر هذا الخطأ وقد تم اضافة هاتين الجملتين الى الكود وعمل بنجاح والحمد لله Dim fShellRun As Object Set fShellRun = CreateObject("Wscript.Shell") strPing = fShellRun.Run(strCommand) الا انه عند عدم وجود اتصال بالانتر نت لا يوجد اعتراض من قبل الكود وتم اهمال ارسال الرسالة التنبيهية بعدم وجود اتصال

بفضل الله أولاً ومن ثم بفضل فكرة استاذي الكبير @Shivan Rekany تمكنت من ايجاد الكود التالي مع بعض التعديلات عليه ليقوم بالمهمة المطلوبة Sub DownloadUpdate() Dim FileNum As Long Dim FileData() As Byte Dim MyFile As String Dim WHTTP As Object Dim str_folder As String On Error Resume Next myIp = "www.google.com" strCommand = "%ComSpec% /C %SystemRoot%\system32\ping.exe -n 1 -w 500 " & myIp & " | " & "%SystemRoot%\system32\find.exe /i " & Chr(34) & "TTL=" & Chr(34) strPing = fShellRun(strCommand) If strPing = "" Then MsgBox "تحقق من اتصالك بالانترنت لكي يتم تنزيل الملف", vbCritical, "فشل التحديث" Else Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5") If Err.Number <> 0 Then Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1") End If On Error GoTo 0 MyFile = "https://drive.google.com/drive/folders/0B9STtJY2DhAoQ1JET3F5N3NiMDQ" WHTTP.Open "GET", MyFile, False WHTTP.send FileData = WHTTP.ResponseBody Set WHTTP = Nothing If Dir("C:\MyDownloads", vbDirectory) = Empty Then MkDir "C:\MyDownloads" FileNum = FreeFile Open "C:\MyDownloads\Activation.mde" For Binary As #FileNum Put #FileNum, 1, FileData Close #FileNum MsgBox " [ C:\MyDownloads ]تم تنزيل ملف التفعيل في المسار التالي", vbInformation + vbMsgBoxRight, "تنبيه" str_folder = "C:\MyDownloads" ' folder to open Call Shell("explorer.exe " & str_folder, vbNormalFocus) DoCmd.Quit End If

ممكن هذا الكود يقوم بهذا العمل تقوم بتعبئة التكست و عند الخروج منه يتم التنسيق Private Sub TextBox1_LostFocus() Application.ScreenUpdating = False TextBox1 = Format(TextBox1, Application.Rept(0, 10)) Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله الكود بعد التعديل Sub saif() Dim sh As Worksheet LR = Cells(Rows.Count, 1).End(xlUp).Row For Each sh In ThisWorkbook.Worksheets For r = 2 To LR If sh.Name = "البرنامج" Then GoTo 2 If Sheets("البرنامج").Cells(r, 1).Value <> Empty Then If Sheets("البرنامج").Cells(r, 1).Value = sh.Name Then Sheets("البرنامج").Range("D" & r & ":M" & r).Copy qq = sh.Cells(100000, 1).End(xlUp).Row + 1 sh.Range("a" & qq).PasteSpecial xlPasteValues End If End If Next 2 Next Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

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

استأذن من استاذنا @jjafferr اتفضلي اليكي هذا الاستعلام التحديث UPDATE DISTINCTROW Cutting INNER JOIN Salary ON Cutting.EmpNumber = Salary.EmpNumber SET Salary.Absent_Cutting = DCount("[ID]","Cutting","[EmpNumber]=" & [Salary]![EmpNumber] & " and [No_of_Absent] <> 0"); واليكي القاعدة بها الاستعلام باسم كويري2 bmn (1).rar

وعليكم السلام اختي في قواعد البيانات ، لا نحفظ حقل محسوب في جدول ، إلا اذا كان كُلاً ولا بُد اعملي استعلام ليعطيك هذه القيمة ، وكلما احتجتي لهذه القيمة لنموذج او تقرير ، فاستعملي الاستعلام جعفر

افتح جدول K4_History في وضع تصميم غير خصائص Indexed لحقل No من Yes (No Duplicates) الى Yes (Duplicates OK) واحفظ التغيرات الجدول وجرب

اتفضل اليك هذا الكود Private Sub Form_AfterUpdate() Dim sql As String sql = "INSERT INTO K4_History ( [No], [Grd-Tot], [Sum-Bal], [Net-Rest], New_K4, Old_K4, New_K6, User_Entry, [Note], K4_Type, Date_Entry ) SELECT Ded_K4_In.[No], Ded_K4_In.[Grd-Tot], Ded_K4_In.[Sum-Bal], Ded_K4_In.[Net-Rest], Ded_K4_In.New_K4, Ded_K4_In.Old_K4, Ded_K4_In.New_K6, Ded_K4_In.User_Entry, Ded_K4_In.Note, Ded_K4_In.K4_Type, Ded_K4_In.Date_Entry FROM Ded_K4_In WHERE (((Ded_K4_In.[No])=[Forms]![Ded-K4-New]![No]));" DoCmd.SetWarnings False DoCmd.RunSQL (sql) DoCmd.SetWarnings True End Sub واليك المرفق DB1 (4).rar

السلام عليكم ========== دالة اليوم هى دالة =SUMVIS(..العمود الذى تريد...) هى دالة من النوع UDF وهى تقوم بجمع قيم فى عمود معين مع تجاهل القيم المخفية المرفق دالة جمع الظاهر فقط.rar

السلام عليكم =========== الاخ حسن هذا شرح بسيط عن الدالة المطلوبة دالة SUBSTITUTE.rar

Function refverseText(mycell) Dim mcount As Long, mtxt As String mcount = Len(mycell.Value) mtxt = mycell.Value Dim m As String For i = mcount To 1 Step -1 m = m & Mid(mtxt, i, 1) Next i refverseText = m End Function reversetext.zip