Foksh

بعد بحثي عن هذا الملف من مشروع إدارة صالة أفراح في العاصمة عمان ، جرب هذا التعديل :- Afra7.accdb

انظر المشكلة :- لاحظ كيف يتم تخزين قيم العنوان الإلكتروني في الجدول داخل الحقل !!!! وهذا مرفقك لتتوضح الصورة لك !! hyperlinErr.accdb

اخي الكريم الموديول ليس له علاقة بهذا الملف .

من نفس المرفق أخي عبداللطيف :-

وعليكم السلام ورحمة الله وبركاته ,, في النموذج ، وبعد ان تحدد مربع النص الذي يتم عرض الروابط فيه ، من تبويب Format - تنسيق ، فعل الخيار التالي :- لتحصل على النتيجة :- إضافة الى ما سبق ، تستطيع إضافة الكود التالي لمربع النص في حدث عند النقر :- Dim link As String link = Me.Emails.Value If link <> "" Then Application.FollowHyperlink link End If حيث في مثال ، اسم مربع النص هنا = Emails

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

لا تحتاج لشرح ، تفقد مرفق الأستاذ @ابو جودي ،والمرفق التالي وستعرف الحل البسيط 1.accdb

وعليكم السلام ورحمة الله وبركاته .. الأمر يسير أخي @عبد اللطيف سلوم ان شاء الله انشئ نموذج وفي زر التسجيل استخدم الكود التالي Private Sub Command7_Click() Dim rs As DAO.Recordset Dim sql As String sql = "SELECT 1 FROM Tbl_Party WHERE DATE_PARTY = #" & Me.DATE_PARTY & "# " & _ "AND ((#" & Me.TIME_PARTY_START & "# BETWEEN TIME_PARTY_START AND TIME_PARTY_END) " & _ "OR (#" & Me.TIME_PARTY_END & "# BETWEEN TIME_PARTY_START AND TIME_PARTY_END) " & _ "OR (TIME_PARTY_START BETWEEN #" & Me.TIME_PARTY_START & "# AND #" & Me.TIME_PARTY_END & "#))" Set rs = CurrentDb.OpenRecordset(sql, dbOpenSnapshot) If Not rs.EOF Then MsgBox "يوجد حجز مسبق لهذه الفترة!", vbExclamation, "تنبيه" Else CurrentDb.Execute "INSERT INTO Tbl_Party (DATE_PARTY, TIME_PARTY_START, TIME_PARTY_END) " & _ "VALUES (#" & Me.DATE_PARTY & "#, #" & Me.TIME_PARTY_START & "#, #" & Me.TIME_PARTY_END & "#)", dbFailOnError MsgBox "تم حفظ الحجز بنجاح!", vbInformation, "تأكيد" End If rs.Close: Set rs = Nothing End Sub WEEDING HALLS.accdb

زي كده

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

ما شاء الله ، تبارك الرحمن سلمت يمناك لهذا الطرح الممتع ,, وجزاك الله كل الخير على مجهودك الجميل والكبير حتى تصل لهذه النتيجة .. اسمح لي بسؤال خطر على بالي :- بما أن الكود يعتمد على مكتبة DAO ؛ هل سيدعم الإصدارات القديمة التي لا تدعم هذه المكتبة !!!

أتمنى أن أكون قد فهمت الفكرة بشكل صحيح .. جرب هذا الكود في الزر Private Sub أمر7_Click() Dim strCriteriaHall1 As String, strCriteriaHall2 As String Dim HallName1 As String, HallName2 As String Dim checkInDate As String Dim existingClient1 As Variant, existingClient2 As Variant Dim existingCheckIn1 As Variant, existingCheckIn2 As Variant Dim existingCheckOut1 As Variant, existingCheckOut2 As Variant HallName1 = Replace(Me.m3.Caption, "'", "''") HallName2 = Replace(Me.m5.Caption, "'", "''") checkInDate = "#" & Format(Me.m4, "mm/dd/yyyy") & "#" strCriteriaHall1 = "HallName='" & HallName1 & "' AND Check_in <= " & checkInDate & " AND Check_out >= " & checkInDate strCriteriaHall2 = "HallName='" & HallName2 & "' AND Check_in <= " & checkInDate & " AND Check_out >= " & checkInDate existingClient1 = DLookup("Client_Name", "tbl_HallReservation", strCriteriaHall1) existingCheckIn1 = DLookup("Check_in", "tbl_HallReservation", strCriteriaHall1) existingCheckOut1 = DLookup("Check_out", "tbl_HallReservation", strCriteriaHall1) existingClient2 = DLookup("Client_Name", "tbl_HallReservation", strCriteriaHall2) existingCheckIn2 = DLookup("Check_in", "tbl_HallReservation", strCriteriaHall2) existingCheckOut2 = DLookup("Check_out", "tbl_HallReservation", strCriteriaHall2) If Not IsNull(existingClient1) Then Me.aa.Value = "القاعة غير متاحة" Me.bb.Value = "الاسم: " & existingClient1 & vbNewLine & _ "القاعة: " & HallName1 & vbNewLine & _ "تاريخ الدخول: " & Format(existingCheckIn1, "dd/mm/yyyy") & vbNewLine & _ "تاريخ الخروج: " & Format(existingCheckOut1, "dd/mm/yyyy") Else Me.aa.Value = "متاحة" Me.bb.Value = "لا توجد حجوزات سابقة لهذه القاعة" End If If Not IsNull(existingClient2) Then Me.DD.Value = "القاعة غير متاحة" Me.ff.Value = "الاسم: " & existingClient2 & vbNewLine & _ "القاعة: " & HallName2 & vbNewLine & _ "تاريخ الدخول: " & Format(existingCheckIn2, "dd/mm/yyyy") & vbNewLine & _ "تاريخ الخروج: " & Format(existingCheckOut2, "dd/mm/yyyy") Else Me.DD.Value = "متاحة" Me.ff.Value = "لا توجد حجوزات سابقة لهذه القاعة" End If End Sub حجز (2).accdb

استغفر الله العظيم ، أخي العزيز الأستاذ @ابو جودي ، أسأل الله لكم الفلاح والنجاح في الدنيا والآخرة ، وأن يزيدكم الله من علمه لما علمكم ,, < انتهينا من دي !! ايه الكلام ده يا عم الحج .. انت حتسيح بقلب المنطقة !!!! هو انا كنت عملت ايه !! ولا هي تتبلاني وخلاااص . وبعدين انا كنت بجاوب هنا أو هناك ؛ تنكر !!! صدقني لهو شرف لي أن أشاطرك الأفكار بكل ود وحب .. شكراً على كلامك الجميل ( محدش يصدقه )

حسناً ، جرب هذا التعديل ، حيث استخدمنا Do Until بدلاً من Continue For .. If Month(Me.txtMonth) = 3 Or Month(Me.txtMonth) = 7 Then myCriteria = "([detach] IN ('موظف', 'عامل متعاقد توقيت كامل', 'عامل متعاقد توقيت جزئي', 'حارس متعاقد توقيت جزئي', 'عون نظافه وتطهير'))" Set rstE = CurrentDb.OpenRecordset("SELECT * FROM Employee WHERE " & myCriteria) If Not rstE.EOF Then Do Until rstE.EOF If DCount("*", "tbl_Loans", "EmployeeID=" & rstE!EmployeeID & " AND [Loan_Type]='Inkhirat' AND [Payment_Month]=#" & Me.txtMonth & "#") = 0 Then rst.AddNew rst!EmployeeID = rstE!EmployeeID rst!Loan_ID = 0 rst!Payment_Month = Me.txtMonth rst!Payment_Made = DLookup("Other_Value", "TblOther", "ID=1") rst!Loan_Type = "Inkhirat" rst!Nr = GetNumDetach(rstE!EmployeeID) rst!Remarks = "إقتطاع من الراتب لإنخراط شهر " & Format(Me.txtMonth, "yyyy/mm") rst!sadad = rst!Payment_Made rst!wada3 = "تم الإنخراط" rst.Update TheSum = TheSum + Nz(rst!Payment_Made, 0) End If rstE.MoveNext Loop End If rstE.Close: Set rstE = Nothing End If

تم الإضافة في المشاركة السابقة أخي الكريم ,,

لا انصحك بهذه الخطوة أخي الكريم ، يعني لو العميل حذف السجل 150 من اصل السجلات 350 ، فسيكون الترتيب = 148 - 149 - 151 - 152 .... إلخ وللأسف لن يتم اضافة الرقم 150 !!!!!!!!

باعتقادي وبأنه الكثير لم يفهم تسلسل ولا آلية ولا فكرة المرفق أو كيفية فهم النتائج في هذا المشروع ، اعتقد إنه يتوجب عليك أخي @طاهر اوفيسنا إعادة النظر في الآلية التي تسير بها في مشروعك . هذا من ناحية طبعاً . من ناحية أخرى ما زلت تفتقر الى الشرح المبسط أو الواضح وتوصيل المعلومة التي من خلالها نستطيع فهم ما تريده . وليس تزويدنا بكود وصورة قد يكون كافياً دائماً لفهم المطلوب . على العموم ، جرب هذا التعديل في النهج كاملاً .. Private Sub cmd_Pay_installments_Click() On Error GoTo err_cmd_Pay_installments_Click Dim rst As DAO.Recordset Dim rstE As DAO.Recordset Dim Rc As Integer, TheSum As Double Dim myCriteria As String Set rst = CurrentDb.OpenRecordset("SELECT * FROM tbl_Loans WHERE [Payment_Month]=#" & Format(Me.txtMonth, "mm/dd/yyyy") & "#") If rst.EOF Then MsgBox " لا توجد إقتطاعات لشهر " & Format(Me.txtMonth, "mmmm yyyy"), vbInformation rst.Close: Set rst = Nothing Exit Sub End If With rst If IsNull(!Payment_Made) And Not IsNull(!Loan_Made) Then If MsgBox("هل تريد توزيع الإقتطاعات لشهر " & Format(Me.txtMonth, "mmmm yyyy") & "؟", vbYesNo + vbQuestion) = vbYes Then Do Until .EOF .Edit If !Nr >= 6 Then !Payment_Made = 0 ElseIf !Loan_Type = "Cridi" Or !Loan_Type = "Elec" Then !Payment_Made = !Loan_Made !sadad = !Loan_Made !Loan_Remise = 0 End If !wada3 = IIf(Nz(!sadad, 0) <> 0, "تم التسديد", "لم يتم التسديد") TheSum = TheSum + Nz(!Payment_Made, 0) .Update .MoveNext Loop ' اقتطاع الانخراط في مارس ويوليو If Month(Me.txtMonth) = 3 Or Month(Me.txtMonth) = 7 Then myCriteria = "([detach] IN ('موظف', 'عامل متعاقد توقيت كامل', 'عامل متعاقد توقيت جزئي', 'حارس متعاقد توقيت جزئي', 'عون نظافه وتطهير'))" Set rstE = CurrentDb.OpenRecordset("SELECT * FROM Employee WHERE " & myCriteria) If Not rstE.EOF Then Do Until rstE.EOF If DCount("*", "tbl_Loans", "EmployeeID=" & rstE!EmployeeID & " AND [Loan_Type]='Inkhirat' AND [Payment_Month]=#" & Me.txtMonth & "#") = 0 Then .AddNew !EmployeeID = rstE!EmployeeID !Loan_ID = 0 !Payment_Month = Me.txtMonth !Payment_Made = DLookup("Other_Value", "TblOther", "ID=1") !Loan_Type = "Inkhirat" !Nr = GetNumDetach(rstE!EmployeeID) !Remarks = "إقتطاع من الراتب لإنخراط شهر " & Format(Me.txtMonth, "yyyy/mm") !sadad = !Payment_Made !wada3 = "تم الإنخراط" .Update TheSum = TheSum + Nz(!Payment_Made, 0) End If rstE.MoveNext Loop End If rstE.Close: Set rstE = Nothing End If ' عرض المجموع النهائي MsgBox "تم توزيع الإقتطاعات بنجاح." & vbCrLf & "المجموع: " & Format(TheSum, "#,##0.00"), vbInformation, "إقتطاعات شهر " & Format(Me.txtMonth, "mmmm yyyy") End If End If End With rst.Close: Set rst = Nothing Exit Sub err_cmd_Pay_installments_Click: MsgBox "خطأ رقم: " & Err.Number & vbCrLf & Err.Description, vbCritical If Not rst Is Nothing Then rst.Close: Set rst = Nothing If Not rstE Is Nothing Then rstE.Close: Set rstE = Nothing End Sub الكود في ملف نصي مضغوط .. Text_VBA.zip

هذا سيعود عليك بمنافع ومضار في نفس الوقت ,, برأيي ان كثرة استخدام فكرة الضغط والإصلاح قد يؤدي الى تلف او فقدان البيانات أو قاعدة البيانات بشكل كامل . لذا عليك توظيف الفكرة بحيث تكون محكومة بمرة واحدة على الأقل في اليوم . طبعاً هو يعتمد ايضاً على ما اذا كانت قاعدة البيانات مقسمة أم لا ,,, جرب هذا الكود لضغط وإصلاح قاعدة البيانات الغير مقسمة ,, Public Function compactDb(ByVal mydb As String, ByVal mypass As String, Optional openIt As Boolean = False) Dim f As Integer Dim filenoext As String, extension As String, Access As String Access = """" & SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE""" filenoext = Left(mydb, InStrRev(mydb, ".")) extension = Right(mydb, Len(mydb) - InStrRev(mydb, ".")) f = FreeFile Open CurrentProject.Path & "\compact.bat" For Output As f Print #f, "CHCP 1256" Print #f, ":checkldb1" Print #f, "if exist """ & filenoext & "l" & extension & """ goto checkldb1" Print #f, Access & " """ & mydb & """" & mypass & " /compact" If openIt Then Print #f, ":checkldb2" Print #f, "if exist """ & filenoext & "l" & extension & """ goto checkldb2" Print #f, Access & " """ & mydb & """" Else Print #f, "del ""%~f0""" End If Close f End Function Public Function CopactMyDb() On Error Resume Next Dim Mypath As String Mypath = CurrentProject.Path & "\" & CurrentProject.Name Call compactDb(Mypath, "", True) Shell """" & Left(Mypath, InStrRev(Mypath, "\")) & "\compact.bat""", 0 DoCmd.Quit acQuitSaveAll End Function الإستدعاء سيكون في الزر في حدث عند النقر كما يلي :- CopactMyDb

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

رابط جروب الواتس أب هنا

مصدر التقرير استعلام ؟؟؟ واذا كان نعم ، هل الكود مرتبط بالاستعلام مصدر التقرير ؟؟

إضافةً لذلك ، المرفق لا يحتوي النموذج frm_repot

وعليكم السلام ورحمة الله وبركاته .. مشاركة مع الاستاذ @أبوبسمله جرب التالي ايضاً ..

وعليكم السلام ورحمة الله وبركاته ، إن كنت من متابعي ومنتسبي جروب الواتس أب ؛ فقد تمت الإجابة عن هذا السؤال سابقاً .. مثال بسيط Main (1).accdb