ابو جودي

السلام عليكم ورحمة الله تعالى وبركاته استاذى الجليل ومعلمى القدير الاستاذ @kkhalifa1960 اسعد الله صباحكم طيب ايه رايك اقول لحضرتك على فكرة بنت حلال وبسيطة قوى قوى وقمة فى السهولة نمسح كل كل الاكواد وكل الوحدات النمطية من المرفق وننشئ وحدة نمطية جديدة مثلا باسم : basFillFields ونضع بها الدوال الاتية Option Compare Database Option Explicit Const ListBoxFormName As String = "frm_Specifications" Public Function OpenListBoxForm(FormName As Form) DoCmd.OpenForm ListBoxFormName, , , , , acDialog, FormName.Name & ";" & FormName.ActiveControl.Name End Function Public Function UpdateFieldFromListBox(FormName As String, FieldName As String, SelectedValue As Variant) Forms(FormName).Controls(FieldName).Value = SelectedValue End Function بس كده وفى كل النماذج فقط يكون الكود Option Compare Database Option Explicit Private Sub CmdClose_Click() DoCmd.Close End Sub اما بالنسبة لنموذج :frm_Specifications سوف نستخدم الاكواد الاتية Option Compare Database Option Explicit Dim Args() As String Private Sub List0_DblClick(Cancel As Integer) Args = Split(Me.OpenArgs, ";") Call UpdateFieldFromListBox(Args(0), Args(1), Me.List0.Value) DoCmd.Close acForm, Me.Name End Sub Private Sub List0_Click() Args = Split(Me.OpenArgs, ";") frm1 = Args(0) Txt2 = Args(1) Me.Txt1 = Me.List0.Column(0) End Sub Private Sub cmdOK_Click() Call UpdateFieldFromListBox(Args(0), Args(1), Me.List0.Value) DoCmd.Close acForm, Me.Name End Sub وطبعا انا استخدمت الاكواد السابقة للحفاظ على التصميم والية العمل وفقا للمرفق تماما ولكن يمكن فقط استخدام هذا الجزء فقط والاستغناء عن باقى الاكواد الاخرى Option Compare Database Option Explicit Dim Args() As String Private Sub List0_DblClick(Cancel As Integer) Args = Split(Me.OpenArgs, ";") Call UpdateFieldFromListBox(Args(0), Args(1), Me.List0.Value) DoCmd.Close acForm, Me.Name End Sub طيب الان نصل الى اهم واجمل جزء الاستدعاء سوف اقوم باستخدام Expression Builder لاستدعاء الدالة بالشكل التالى =OpenListBoxForm([Form]) واخيرا المرفق DDTest602-3.accdb

اتفضل Dim Omra As Boolean Dim OmraAnne As Integer Omra = IIf(DLookup("Haj", "Mena7", "EmployeeID =" & Me.EmployeeID & " AND Menha_ID = 11") = -1, True, False) OmraAnne = DLookup("annee", "Mena7", "EmployeeID =" & Me.EmployeeID & " AND Menha_ID = 11") If Omra = True Then MsgBox "هذا الموظف مستفيد من منحة العمرة خلال سنة " & OmraAnne Me.Undo Exit Sub End If

ومشاركة واثراء للموضوع ازيدكم من الشعر بيتا لماذا دائما نتجاهل استخدام دالة Switch و اول ما يشغل بالنا هو دائما دالة iif استخدام Switch انا احبه وافضله عن استخدام دالة iif يعدا قل تعقيدا واكثر سهولة فى الفهم ممكن استخدام الكود االتالى ' Sets rb to "normal" if Hb is between 10 and 16 (inclusive). ' Sets rb to "up" if Hb is greater than 16. ' Sets rb to "down" if Hb is less than 10. ' Sets rb to "" if Hb is blank. Me.rb = Switch( _ [Hb] >= 10 And [Hb] <= 16, "normal", _ [Hb] > 16, "up", _ [Hb] < 10, "down", _ [Hb] = "", "" _ ) طبعا انا قمت بكتابته على هذا النحو للتوضيح ممكن كتابته بالشكل التالى Me.rb = Switch([Hb] >= 10 And [Hb] <= 16, "normal", [Hb] > 16, "up", [Hb] < 10, "down", [Hb] = "", "")

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

جربى الكود دع يا دكتور Private Sub btnAdd_Click() On Error GoTo ErrorHandler Dim db As DAO.Database Dim rs As DAO.Recordset Dim fixedNameValue As String Dim newResultValue As String Dim fixedDefaultValue As Variant Dim fixedNormalValue As Variant Dim reportNameValue As Variant Dim sql As String Dim MAXCODE As Long ' الحصول على القيم من الحقول fixedNameValue = Me.testnameN newResultValue = Me.Newresult fixedDefaultValue = Me.fixeddefault fixedNormalValue = Me.fixednormal reportNameValue = Me.Reportname ' التحقق من أن القيم ليست فارغة If IsNull(fixedDefaultValue) Or IsNull(fixedNormalValue) Or IsNull(reportNameValue) Then MsgBox "يرجى استكمال باقي البيانات (fixeddefault, fixednormal, Reportname) قبل الإضافة.", vbExclamation Exit Sub End If If IsNull(fixedNameValue) Or IsNull(newResultValue) Then MsgBox "يجب إدخال القيم المراد إضافتها ثم الضغط على زر الإضافة.", vbExclamation Exit Sub End If ' فتح قاعدة البيانات Set db = CurrentDb ' التحقق مما إذا كانت القيم موجودة بالفعل sql = "SELECT COUNT(*) AS RecordCount FROM fixedresults_tbl WHERE Fixedname = '" & fixedNameValue & "' AND Fixedresult = '" & newResultValue & "'" Set rs = db.OpenRecordset(sql) If Not rs.EOF And rs!RecordCount > 0 Then MsgBox "القيمة المدخلة موجودة مسبقًا.", vbExclamation rs.Close Set rs = Nothing Set db = Nothing Exit Sub End If rs.Close Set rs = Nothing ' تحديد الرقم الجديد MAXCODE = Nz(DMax("code", "fixedresults_tbl"), 0) Me.code.Value = MAXCODE + 1 ' إضافة السجل الجديد إلى fixedresults_tbl sql = "INSERT INTO fixedresults_tbl (code, Fixedname, Fixedresult) " & _ "VALUES (" & Me.code.Value & ", '" & fixedNameValue & "', '" & newResultValue & "')" db.Execute sql, dbFailOnError ' إعادة تحميل القائمة وتفريغ الحقول Resultlist.Requery Me.Newresult.Value = "" MsgBox "تمت الإضافة بنجاح!", vbInformation ' فتح الجدول المراد التحديث له Set rs = db.OpenRecordset("Fixed_tbl", dbOpenDynaset) ' التحقق مما إذا كان السجل موجود بالفعل لمنع التكرار rs.FindFirst "fixedname = '" & fixedNameValue & "'" If rs.NoMatch Then ' إضافة سجل جديد rs.AddNew rs!fixedname = fixedNameValue rs!fixeddefault = fixedDefaultValue rs!fixednormal = fixedNormalValue rs!Reportname = reportNameValue rs.Update Else ' تحديث السجل الموجود rs.Edit rs!fixeddefault = fixedDefaultValue rs!fixednormal = fixedNormalValue rs!Reportname = reportNameValue rs.Update End If ' إغلاق مجموعة السجلات rs.Close Set rs = Nothing Set db = Nothing MsgBox "تمت الإضافة بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical If Not rs Is Nothing Then rs.Close Set rs = Nothing End If If Not db Is Nothing Then Set db = Nothing End If End Sub

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

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

وطبعا لان المرفقات ممكن يصيبها العطب الشغل كله كله كله تقريبا من خلال الاكواد فى الوحدة النمطية اللى باسم : basCrossword وباقى الاكواد فى النماذح مجرد استدعاء لا اكثر ولا اقل Option Compare Database Option Explicit ' Constants for form and table names Public Const Cnst_FormName_Settings As String = "frmCrosswordSetting" Public Const Cnst_FormName_QuestionsAnswers As String = "frmQuestionsAnswers" Public Const Cnst_FormName_Crossword As String = "frmCrossword" Public Const Cnst_TableName_Settings As String = "tblSetting" Public Const Cnst_TableName_Questions As String = "tblQuestionsAnswers" Public Const Cnst_TableName_GridMap As String = "tblCrosswordGridMap" ' Variables for grid settings Public intRowCellsNumber As Integer Public intTotalCellsNumber As Integer Public strLanguage As String ' Sub to add a new setting Public Sub AddSetting() On Error GoTo AddSetting_Error ' Delete records from related tables before adding new settings DeleteRecordsFromTable Cnst_TableName_GridMap DeleteRecordsFromTable Cnst_TableName_Questions DeleteRecordsFromTable Cnst_TableName_Settings Dim db As DAO.Database Dim rs As DAO.Recordset Set db = CurrentDb Set rs = db.OpenRecordset(Cnst_TableName_Settings, dbOpenDynaset) ' Add a new record to the setting table if it's empty If rs.EOF And rs.BOF Then rs.AddNew rs!CountRowCol = intRowCellsNumber rs!Language = strLanguage rs.Update Else MsgBox "Table is not empty. Add records accordingly." End If rs.Close Set rs = Nothing Set db = Nothing Exit Sub AddSetting_Error: MsgBox "Error adding records: " & Err.Description, vbExclamation End Sub ' Sub to create a new grid Public Sub CreateNewGrid() On Error GoTo CreateNewGrid_Error Dim frm As Form Dim intColumnIndex As Integer Dim intRowIndex As Integer DoCmd.OpenForm Cnst_FormName_Crossword, acDesign Set frm = Forms(Cnst_FormName_Crossword) ' Define positions for controls Dim intPosTop As Integer Dim intPosLeft As Integer intPosTop = 0.1667 * 1440 intPosLeft = 0.0833 * 1440 ' Define sizes for controls Dim intCellWidth As Integer Dim intCellHeight As Integer intCellWidth = 0.3556 * 1440 intCellHeight = 0.3556 * 1440 ' Define left position for labels and text boxes Dim intPosLeftLabel As Integer Dim intPosLeftTxtBox As Integer intPosLeftLabel = intPosLeft + intCellWidth intPosLeftTxtBox = intPosLeft + intCellWidth ' Create column labels For intColumnIndex = 1 To intRowCellsNumber Dim strColLabelName As String strColLabelName = "lblCol" & intColumnIndex Dim intColLabelLeft As Integer intColLabelLeft = intPosLeftLabel + ((intColumnIndex - 1) * intCellWidth) Dim colLabel As control Set colLabel = CreateControl(Cnst_FormName_Crossword, acLabel, acDetail, , , intColLabelLeft, intPosTop, intCellWidth, intCellHeight) colLabel.Name = strColLabelName colLabel.Caption = intColumnIndex colLabel.Tag = "GridControl" colLabel.Visible = True colLabel.TextAlign = 2 ' Center alignment Next intColumnIndex ' Create row labels For intRowIndex = 1 To intRowCellsNumber Dim strRowLabelName As String strRowLabelName = "lblRow" & intRowIndex Dim intRowLabelTop As Integer intRowLabelTop = intPosTop + (intRowIndex * intCellHeight) Dim rowLabel As control Set rowLabel = CreateControl(Cnst_FormName_Crossword, acLabel, acDetail, , , intPosLeft, intRowLabelTop, intCellWidth, intCellHeight) rowLabel.Name = strRowLabelName rowLabel.Caption = intRowIndex rowLabel.Tag = "GridControl" rowLabel.Visible = True rowLabel.TextAlign = 2 ' Center alignment Next intRowIndex ' Create text boxes for grid For intRowIndex = 1 To intRowCellsNumber For intColumnIndex = 1 To intRowCellsNumber Dim strControlName As String strControlName = "txt" & ((intRowIndex - 1) * intRowCellsNumber + intColumnIndex) Dim ctrl As control Set ctrl = CreateControl(Cnst_FormName_Crossword, acTextBox, acDetail, , , intPosLeftTxtBox + ((intColumnIndex - 1) * intCellWidth), intPosTop + (intRowIndex * intCellHeight), intCellWidth, intCellHeight) ctrl.Name = strControlName ctrl.Tag = "GridControl" ctrl.Visible = True ctrl.TextAlign = 2 ' Center alignment Next intColumnIndex Next intRowIndex DoCmd.Close acForm, Cnst_FormName_Crossword, acSaveYes Exit Sub CreateNewGrid_Error: MsgBox "Error creating new grid: " & Err.Description End Sub ' Ensure the form exists, and create it if it doesn't Public Sub EnsureFormExists() On Error Resume Next ' Try to open the form DoCmd.OpenForm Cnst_FormName_Crossword, acNormal If Err.Number <> 0 Then ' If form doesn't exist, create it CreateNewForm End If DoCmd.Close acForm, Cnst_FormName_Crossword End Sub ' Create a new form and save it with the specified name Public Sub CreateNewForm() Dim frmNewForm As Form Set frmNewForm = CreateForm ' Set form properties With frmNewForm .ScrollBars = 0 ' Neither .RecordSelectors = False ' No record selector .NavigationButtons = False ' No Navigation End With Dim strTempFormName As String strTempFormName = frmNewForm.Name ' Save the form DoCmd.Save acForm, strTempFormName DoCmd.Close acForm, strTempFormName ' Rename the form to the main form name DoCmd.Rename Cnst_FormName_Crossword, acForm, strTempFormName ' Open the settings form DoCmd.Close acForm, Cnst_FormName_Settings, acSaveYes DoCmd.OpenForm Cnst_FormName_Settings, acNormal End Sub ' Sub to delete the old grid Public Sub DeleteOldGrid() On Error Resume Next Dim frm As Form Dim ctrl As control Dim colControlsToDelete As New Collection Dim intIndex As Integer DoCmd.OpenForm Cnst_FormName_Crossword, acDesign Set frm = Forms(Cnst_FormName_Crossword) ' Collect controls to delete For Each ctrl In frm.Controls If ctrl.ControlType = acTextBox Or ctrl.ControlType = acLabel Then If ctrl.Tag = "GridControl" Then colControlsToDelete.Add ctrl.Name End If End If Next ctrl ' Delete collected controls For intIndex = colControlsToDelete.Count To 1 Step -1 DeleteControl Cnst_FormName_Crossword, colControlsToDelete(intIndex) Next intIndex '||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| DoCmd.Close ObjectType:=acForm, ObjectName:=Cnst_FormName_Crossword, Save:=acSaveYes Set ctrl = Nothing Set frm = Nothing End Sub ' Generate a grid based on the total number of controls Public Sub GenerateGrid() On Error GoTo GenerateGrid_Error EnsureFormExists If intRowCellsNumber > 0 And intRowCellsNumber <= 144 Then DeleteOldGrid CreateNewGrid AddRecordsToTable intTotalCellsNumber DoCmd.Close acForm, "frmNewSettingGame", acSaveYes Else MsgBox "Please enter an integer between 3 and 12." End If Exit Sub GenerateGrid_Error: CreateNewForm End Sub ' Function to add records to the grid map table Public Function AddRecordsToTable(ByVal intNumberOfRecords As Integer) As Boolean On Error GoTo AddRecords_Error Dim db As DAO.Database Dim rs As DAO.Recordset Dim intIndex As Integer DeleteRecordsFromTable Cnst_TableName_GridMap DeleteRecordsFromTable Cnst_TableName_Questions Set db = CurrentDb Set rs = db.OpenRecordset(Cnst_TableName_GridMap, dbOpenDynaset) If rs.EOF And rs.BOF Then ' If the table is empty, add the required number of records For intIndex = 1 To intNumberOfRecords rs.AddNew rs!characterID = intIndex rs.Update Next intIndex Else ' If the table is not empty, inform the user MsgBox "Table is not empty. Add records accordingly." End If rs.Close Set rs = Nothing Set db = Nothing AddRecordsToTable = True Exit Function AddRecords_Error: DeleteRecordsFromTable Cnst_TableName_GridMap DeleteRecordsFromTable Cnst_TableName_Questions rs.Close Set rs = Nothing Set db = Nothing AddRecordsToTable = False End Function ' Sub to delete all records from a specified table Public Sub DeleteRecordsFromTable(ByVal strTableName As String) On Error GoTo DeleteRecords_Error Dim db As DAO.Database Dim strSQL As String Set db = CurrentDb ' Define SQL statement to delete all records from the specified table strSQL = "DELETE FROM " & strTableName ' Execute SQL statement db.Execute strSQL, dbFailOnError Set db = Nothing Exit Sub DeleteRecords_Error: MsgBox "Error deleting records: " & Err.Description, vbExclamation Set db = Nothing End Sub ' Function to check if a field exists in a recordset Private Function FieldExists(ByVal rs As DAO.Recordset, ByVal strFieldName As String) As Boolean On Error Resume Next FieldExists = (Not IsError(rs.Fields(strFieldName).Value)) End Function ' Function to retrieve settings from Cnst_TableName_Settings table ' Uses DLookup and Split functions to retrieve values for CountRowCol and Language fields ' Returns True if successful, False otherwise Public Function GetSettings() As Boolean Dim settingRow As String Dim settingsArray() As String Dim rowCellsNumber As Integer Dim Language As String ' Retrieve the full row value from the table settingRow = DLookup("CountRowCol & ',' & Language", Cnst_TableName_Settings) ' Use Split function to separate the retrieved values settingsArray = Split(settingRow, ",") ' Retrieve CountRowCol value from the table If UBound(settingsArray) >= 0 Then intRowCellsNumber = Val(settingsArray(0)) ' Convert value to integer End If ' Retrieve Language value from the table If UBound(settingsArray) >= 1 Then strLanguage = settingsArray(1) End If ' ' You can use the retrieved values as needed here ' Debug.Print "Row/Column Count: " & intRowCellsNumber ' Debug.Print "Language: " & strLanguage ' Set the function return value to True to indicate success GetSettings = True End Function ' Set frm = Forms!frmMain!frmCrossword.Form Public Function UpdateGridWithWords() On Error GoTo UpdateGridWithWords_Error Dim db As DAO.Database Dim rs As DAO.Recordset Dim RSCrossword As DAO.Recordset Dim QuestionValue As String Dim AnswerValue As String Dim StartRow As Integer Dim StartCol As Integer Dim Direction As String Dim i As Integer Dim intQuestionID As Integer Dim frm As Form Set db = CurrentDb() Set rs = db.OpenRecordset(Cnst_TableName_Questions, dbOpenDynaset) Set RSCrossword = db.OpenRecordset(Cnst_TableName_GridMap, dbOpenDynaset) ' Set frm = Forms(strformGrid).Form ' Get the reference to the open form Set frm = Forms(Cnst_FormName_Settings)(Cnst_FormName_Crossword).Form If Not (rs.EOF And rs.BOF) Then rs.MoveFirst Do While Not rs.EOF If Not FieldExists(rs, "QuestionID") Or Not FieldExists(rs, "Question") Or Not FieldExists(rs, "Answer") Or Not FieldExists(rs, "StartRow") Or Not FieldExists(rs, "StartCol") Or Not FieldExists(rs, "Direction") Then MsgBox "Error: One or more required fields are missing in the table " & Cnst_TableName_Questions, vbExclamation Exit Function End If intQuestionID = rs!QuestionID QuestionValue = rs!Question AnswerValue = Replace(rs!Answer, " ", "") StartRow = rs!StartRow StartCol = rs!StartCol Direction = rs!Direction For i = 0 To Len(AnswerValue) - 1 Dim controlName As String Dim characterID As Integer Dim currentChar As String currentChar = Mid(AnswerValue, i + 1, 1) ' Get the current character If strLanguage = "Arabic" Then If Direction = "Horizontal" Then controlName = "txt" & ((StartRow - 1) * intRowCellsNumber + (StartCol - i)) characterID = (StartRow - 1) * intRowCellsNumber + (StartCol - i) ElseIf Direction = "Vertical" Then controlName = "txt" & ((StartRow - 1 + i) * intRowCellsNumber + StartCol) characterID = (StartRow - 1 + i) * intRowCellsNumber + StartCol End If ElseIf strLanguage = "English" Then If Direction = "Horizontal" Then controlName = "txt" & ((StartRow - 1) * intRowCellsNumber + (StartCol + i)) characterID = (StartRow - 1) * intRowCellsNumber + (StartCol + i) ElseIf Direction = "Vertical" Then controlName = "txt" & ((StartRow - 1 + i) * intRowCellsNumber + StartCol) characterID = (StartRow - 1 + i) * intRowCellsNumber + StartCol End If End If With RSCrossword .FindFirst "characterID = " & characterID If Not .NoMatch Then .Edit !QuestionID = intQuestionID !AnswerChar = currentChar .Update End If End With If frm.Controls(controlName).Tag = "GridControl" Then frm.Controls(controlName).Value = currentChar End If Next i rs.MoveNext Loop End If rs.Close RSCrossword.Close Set rs = Nothing Set RSCrossword = Nothing Set db = Nothing Set frm = Nothing Exit Function UpdateGridWithWords_Error: Debug.Print "Error updating grid with words: " & Err.Number & " " & Err.Description End Function Public Sub RepaintAndProcessEvents(ByRef formOrControl As Object) ' Repaint the form or control formOrControl.Repaint ' Allow the system to process events DoEvents End Sub ولو سمعت حد بيقول عاوز شرح هاخد بعضى واروح العب فى حتة تانيه بهزر طبعا اللى عاوز شرح يتعب شوية ويحاول يحلل ويفهم ولما يعطل يسأل ما هو مش هأكتب الكود فى ساعات واشرحه فى ايام

طيب ممكن حضرتك تجربى الاتى اضافة الدالة الاتية فى وحدة نمطية Public Sub RepaintAndProcessEvents(ByRef formOrControl As Object) ' Repaint the form or control formOrControl.Repaint ' Allow the system to process events DoEvents End Sub وبعدين كود الحذف على زر الامر بالشكل ده Private Sub YourDeleteButton_Click() If MsgBox("Are you sure you want to delete the record?", vbYesNo, "Delete Confirmation") = vbYes Then DoCmd.SetWarnings (0) ' Query to delete records from test_order_tbl Dim strSQL1 As String strSQL1 = "DELETE FROM test_order_tbl " & _ "WHERE ID=" & Forms![reservation_frm]![ID] & ";" DoCmd.RunSQL strSQL1 ' Query to delete records from reservation_tbl Dim strSQL2 As String strSQL2 = "DELETE FROM reservation_tbl " & _ "WHERE ID=" & Forms![reservation_frm]![ID] & ";" DoCmd.RunSQL strSQL2 ' Requery to refresh the record list selected_list.Requery DoCmd.SetWarnings (1) ' Repaint the form and process events RepaintAndProcessEvents Me Else DoCmd.CancelEvent End If End Sub

شفاك الله وجمع لك بين الأجر والعافية .. طهور ان شاء الله عجزت ايه بس يا عم انت هتتدلع انشف كده 😡 ايه الجيل ده يا ربى

استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل الموضوع اعتقد لا علاقة له بالحماية فالقاعدة المرفقة تم عملها بمحرك اكسس قديم والاصدارات الحديثة لا تستطيع التعامل معها او فتحها

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

طيب اتفضل يا سيدى اللبنة الاولى لـ Version 2.16 إن شاء الله الاول استخدم زر الامر Go To Crossword Setting بكده تروح لنموذج اعداد الاسئلة وعلشان تشوف الحلويات والجمال تعالى نرخم ع الاكسس علشان نخليه ينفذ طلباتنا : دوس ع الزرار Update Grid وبعد كده علشان تاخد لفة اغلق النموذج وروح للنموذج frmSplash البيانات اللى ظاهرة دى هى الاعدادت الحالية والتى تبين نوع اللغة لوضع الاسئلة والاجوبة وعدد مربعات الشبكة فى الصف الواحد والمرة دى اختر زر الامر New Setting Game من النموذج اللى حيفتح اختار شكل الشبكة ونوع اللغة وجرب اكتر من مره اه مفيش خدع ولا تركات ولا مربعات مخفيه ده بئه شغل فاخر من الاخر عاوز تشوف حلويات اكتر من كده روح يا سيدى وكمل لعب وامسح النموذج بتاع الشبكة خالص frmCrossword وبعد كده خد لفة تانى وروح للنموذج frmSplash والمرة دى برضو اختر زر الامر New Setting Game من النموذج اللى حيفتح اختار شكل الشبكة ونوع اللغة وجرب اكتر من مره وشوف نموذج frmCrossword هتلاقيه رجع تانى ما هو لازقه عامل زى القرش البرانى تخذفة وتمحيه يلف ويرجع لك تانى وكمل انت بقة اظن انا كده عملت معاك فوق الصح الباقى شوية ظبط عادى لا اكتر ولا اقل والموضوع سهل سهل خااااالص ولذيذ ولا اروع والله بجد وكده نقدر نقول نلعب ونتعلم ونتحدى نفسنا والاكسس وبكده انا فى انتظار رأى معلمى الجليل واستاذى القدير و والدى الحبيب الاستاذ @ابوخليل فى الافكار المتواضعة دى لعمل نسخة حبيننا الغالى الاستاذ @Moosak حققنا له حلمه فى عمل Version 2.16 إن شاء الله ؟ Officena Crossword Game.accdb

طيب استاذ @Moosak بما انك لك السبق فى هذا الموضوع بصراحة انا قبل فترة حاولت تصميم قاعدة وبسبب انشغالى فى العمل توقفت كالعادة ولكن بما ان استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل أعجبته الفكرة وكانت هذه كلماته بالعند فى استاذى الجليل ومعلمى القدير صاحب المكتبة العامرة الاستاذ @Moosak فى شغل احترافى زى القاعدة فى المشاركة الاصلية وفى شغل فاخر من الاخر ايون صدقنى زيمبئولك كده الشغل الفاخر من الاخر بقه لما تفتح القاعدة تحدد لغة الاسئلة والاجوبة عربى واللا انجليزى لانها تفرق طبعا فى اتجاه النص >>---> اومااااااااااااال وكمان تحدد اجمالى مربعات الشبكة ان هنا شايفها مثبته 10 * 10 تقريبا يكون فى مرونه فى وضع وتعديل الاسئلة والاجوبة واللا ايه الكلام ؟!

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

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

السلام عليكم ورحمة الله تعالى وبركاته عارف ان الموضوع قديم وانا كنت قلت عاوز لها روقان واحلى سطل شاى وللاسف كان عندى مشكلة فى الشاى وبمجرد حل المشكلة عدت اليكم سريعا شوفوا انا بصراحة كنت بدأت في التصميم ولا اعرف سبب انشغالي واليوم وانا ابحث عن شيء في حاسوبي وجدت المرفق وتذكرت الموضوع وقررت ان اكمل ما بدأته أعجبتني أفكار الأستاذ @Moosak وختامها مسك طبعا ابهرني أستاذي الجليل ومعلمي القدير الأستاذ @أبو إبراهيم الغامدي ساحر ربط الاكس بلغة الـ HTML وأخيرا أفكاري المتواضعة OfficenaPattern.accdb

من واقع المرفق ايه الكود اللى بينفذ طلبك اللى فى الحدث الحالى ؟؟

خير الكلام ما قل ودل واجيبك بقوله تعالى يعلم السر واخفى اخى يا رعاك الله لا تجتزئ الكلام تركت كل الرد وفقط تعلق على الكلمة بخيل اكثر ما اكرهه هو تصيد أخطاء الاخرين على كل كان توجيه في صورة مزاح ولتعلم كل ما يقدم هنا ابتغاء مرضاة الله ولوجه الله تعالى ولا نحتسب ما نقدم الا كذلك اذا انت شخص جاسر وجسور ولا تفهم ولا تحب المزاح اعتذر اليك ردى السابق بصفة شخصية لا علاقة له بأى القاب تتبعها عضويتي لأنه لا نتعامل هنا باي القاب التعامل هنا كما سبق و أوضحت لوجه الله تعالى أخى الحبيب كن هين لين وبما انك عضو جديد وبما انك لك كل الحق في طرح اسئلتك لتحصل من وراء ذلك مبتغاك عليك واجبات كذلك اذا اتبع الواجبات حتى تحصد الحقوق اول الواجبات كان اولى بك قبل المشاركة قراءة قوانين المنتدى https://www.officena.net/Tips/Questions.htm والتى ستجد ضمنها على سبيل المثال والذى كان سببا فى عدم حصولك على النتيجة طيب وقبل مغادرتي فهم السؤال بشكل نموذجي يعين على الإجابة عليه بشكل نموذجي فهم السؤال جيدا يوفر علينا وقت وجهد ثمينين نهدرهما اطرح سؤالك بشكل كاف وبين الهدف والسيناريو وفق المرفق حتى تجد من يستطيع مساعدتك اهلا بك بين اخوانك

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

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

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

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

شوفى يا دكتور دا شئ طبيعى هذه المشكلة بسبب استخدام الكود VBA لتعيين RecordSource للنموذج فتتأخر عملية تحميل البيانات بسبب تنفيذ الاستعلام في كل مرة يتم فيها فتح النموذج و هذا يحدث لأن الاستعلام يتم إعداده وتنفيذه في وقت التشغيل (runtime) ولكن عند استخدام الاستعلام المحفوظ مسبقا في النموذج يتم تحميل البيانات بشكل أسرع لأنه يتم تحميلها مباشرة من قاعدة البيانات دون تأخير إضافي ايه وجه السبب في تحويل الاستعلام بدل من استخدامه مباشرة كمصدر بيانات للنموذج الى تحويله الى كود أولا ثم تمريره الى مصدر بيانات النموذج ؟؟!

انا اسف يا دكتور تسرعت بوضع الرد ولم انتبه الى ان حضرتك عاوزة جملة الاستعلام فى الكود تكون RecordSource اتفضلى Sub SetFormRecordSource() Dim sql As String Dim formID As String ' Get the value of the ID field from the form formID = Forms!visit_frm!ID ' Build the SQL query sql = "SELECT CBC_tbl.ID, CBC_tbl.tdate, CBC_tbl.code, CBC_tbl.age, CBC_tbl.hgb, CBC_tbl.hgb_s, " & _ "CBC_tbl.rbc, CBC_tbl.rbc_s, CBC_tbl.hct, CBC_tbl.hct_s, CBC_tbl.hgbp, CBC_tbl.mcv, " & _ "CBC_tbl.mcv_s, CBC_tbl.mch, CBC_tbl.mch_s, CBC_tbl.mchc, CBC_tbl.mchc_s, CBC_tbl.rdwcv, " & _ "CBC_tbl.rdwcv_s, CBC_tbl.rdwsd, CBC_tbl.rdwsd_s, CBC_tbl.plt, CBC_tbl.plt_s, CBC_tbl.pct, " & _ "CBC_tbl.pct_s, CBC_tbl.pdw, CBC_tbl.pdw_s, CBC_tbl.mpv, CBC_tbl.mpv_s, CBC_tbl.wbc, CBC_tbl.wbc_s, " & _ "CBC_tbl.netp, CBC_tbl.netp_s, CBC_tbl.lymp, CBC_tbl.lymp_s, CBC_tbl.monp, CBC_tbl.monp_s, " & _ "CBC_tbl.eosp, CBC_tbl.eosp_s, CBC_tbl.basp, CBC_tbl.basp_s, CBC_tbl.net, CBC_tbl.net_s, " & _ "CBC_tbl.lym, CBC_tbl.lym_s, CBC_tbl.mon, CBC_tbl.mon_s, CBC_tbl.eos, CBC_tbl.eos_s, " & _ "CBC_tbl.bas, CBC_tbl.bas_s, CBC_tbl.MIDp, CBC_tbl.MIDp_s, CBC_tbl.Mid, CBC_tbl.MID_s, " & _ "CBC_tbl.comment, CBC_tbl.segmp, CBC_tbl.segmp_s, CBC_tbl.bandp, CBC_tbl.bandp_s, " & _ "CBC_tbl.segm, CBC_tbl.segm_s, CBC_tbl.[band], CBC_tbl.band_s, CBC_tbl.WBC_HISTOGRAM, " & _ "CBC_tbl.RBC_HISTOGRAM, CBC_tbl.PLT_HISTOGRAM " & _ "FROM CBC_tbl " & _ "WHERE CBC_tbl.ID=" & formID & ";" ' Set the RecordSource of the form Me.RecordSource = sql End Sub Private Sub Form_Open(Cancel As Integer) SetFormRecordSource End Sub