ابو جودي

بصى يا باش مهندسة حنان خلينا نتفق على شئ الاكسس لا يتعامل بمقياس السنتيمتر فى القياسات ولكن يتعامل بالـ Twips يعنى الرقم اللى حضرتك ناوية تسجليه فى الجدول هيكون بالسنتميتر وطبعا ده كان وفقا لطلب الدكتورة سلمى اللى لازم تطلع عنينا بطلباتها لانها عاوزة تسجل الهوامش بالسنتميتر طيبا علشان نحول من انا كتبت الدالة دى Public Function CmToTwips(cm As Double) As Long CmToTwips = cm * 567 End Function فطبيعيى ان حضرتك لو كتبتى ارقام غير منطقية تحصلى على نتيجة غير منطقية لذلك انا افضل فكرة حضرتك DoCmd.RunCommand acCmdPageSetup

لا شكر على واجب تحت امرك يا دكتور

اهلا بيكى يا افندم وفكرة حضرتك حلوة جدا فكرتنى بشئ انتظروا وسوف اوافيكم بأفكار رائعة ان شاء الله

والله يا دكتور انا كنت بأجهز فكرة

اتفضلى يا استاذة @safaa salem5 المرفق هوامش التقارير.accdb

هأرفع المرفق حالا ادينى دقايق اسف النور كان قاطع

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

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

طيب المرفق 3 الطريقة التقليدية العادية المرفق 4 بطريقة الدالة التى قمت بشرحها قبل قليل اولا يجب تعديل مصدر بيانات مربع السرد ليحتوى على قيم الاشتراك test (3) .accdb test (4) .accdb

شوف يا سيدى انا كتبت دالة فى مودبول يعنى فى وحدة نمطية علشان نقدر نستخدمها فى اى مكان وبكل سهولة معلش يبدو انه عند التعامل معى من الوهلة تعتبرنى معقد ولكن انا اتعب قلبلا فى البداية عند بلورة الفكرة واثناء كتابتها ولكن النتيجة بعد ذلك تاتى بافضل الثمار لقد قمت بكتابة هذه الدالة Option Compare Database Option Explicit ' This function automatically fills a text box based on the value of a combo box. ' Parameters: ' form: Reference to the form containing the controls. ' comboBoxName: Name of the combo box control. ' Optional textBoxName: Name of the text box control to be filled automatically. Default is "TextBoxName". ' Optional multiSelect: Boolean to indicate if the combo box allows multiple selections. Default is False. ' Optional columnIndex: Index of the column to be used if the combo box has multiple columns. Default is 0. Public Sub FillTextBoxFromComboBox(Form As Form, comboBoxName As String, Optional textBoxName As String = "TextBoxName", Optional multiSelect As Boolean = False, Optional columnIndex As Integer = 0) ' On Error GoTo ErrorHandler ' Reference to the combo box control Dim comboBox As comboBox Set comboBox = Form.Controls(comboBoxName) ' Reference to the text box control Dim textBox As textBox Set textBox = Form.Controls(textBoxName) ' Check if the combo box contains items If comboBox.ListCount > 0 Then ' Single column case If comboBox.ColumnCount = 1 Then ' Check if multi-select is enabled If Not multiSelect Then ' Single value textBox.Value = comboBox.Value Else ' Multi-value Dim selectedItems As String Dim i As Integer For i = 0 To comboBox.ItemsSelected.Count - 1 selectedItems = selectedItems & comboBox.ItemData(comboBox.ItemsSelected(i)) & "; " Next i ' Remove the trailing semicolon If Len(selectedItems) > 2 Then selectedItems = Left(selectedItems, Len(selectedItems) - 2) Else selectedItems = "" End If textBox.Value = selectedItems End If ' Multiple columns case ElseIf comboBox.ColumnCount > 1 Then ' Check if multi-select is enabled If Not multiSelect Then ' Single value textBox.Value = comboBox.Column(columnIndex) ' Adjust the column index here as needed Else ' Multi-value For i = 0 To comboBox.ItemsSelected.Count - 1 selectedItems = selectedItems & comboBox.Column(columnIndex, comboBox.ItemsSelected(i)) & "; " ' Adjust the column index here as needed Next i ' Remove the trailing semicolon If Len(selectedItems) > 2 Then selectedItems = Left(selectedItems, Len(selectedItems) - 2) Else selectedItems = "" End If textBox.Value = selectedItems End If End If End If ' Exit Sub ' 'ErrorHandler: ' Select Case Err.Number ' Case 5 ' MsgBox "Error 5: Invalid procedure call or argument. Check if the selectedItems length is valid.", vbExclamation, "Error in FillTextBoxFromComboBox" ' Case 13 ' MsgBox "Error 13: Type mismatch. Ensure the correct data types are used.", vbExclamation, "Error in FillTextBoxFromComboBox" ' Case 91 ' MsgBox "Error 91: Object variable or With block variable not set. Ensure all controls are properly referenced.", vbExclamation, "Error in FillTextBoxFromComboBox" ' Case 424 ' MsgBox "Error 424: Object required. Ensure all controls exist on the form.", vbExclamation, "Error in FillTextBoxFromComboBox" ' Case Else ' MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "Error in FillTextBoxFromComboBox" ' End Select End Sub على ان يتم استدعاء الدالة بالشكل التالى ' Replace "ComboBoxName" and "TextBoxName" with the actual names of your controls ' Call FillTextBoxFromComboBox(Me, "ComboBoxName", "TextBoxName", False, 1) ' Adjust parameters as needed فى اى نموذج ومع اى مربع تحرير وسرد وع اى مربع نص مهما كانت الاسماء من خلال الكود المناسب تبعا للحالات التى شرحتها لك قبل قليل حسب مربع التحرير والسرد كل ما عليك فقط تغيير اسم ComboBoxName فى اكواد الاستدعاء باسم مربع السرد الذى تريد التعامل معه باحضار بياناته وكذلك تغيير اسم TextBoxName باسم مربع النص ' Single Column, Single Value: Call FillTextBoxFromComboBox(Me, "ComboBoxName") ' Single Column, Multi-Value: Call FillTextBoxFromComboBox(Me, "ComboBoxName", "TextBoxName", True) ' Multiple Columns, Single Value: Call FillTextBoxFromComboBox(Me, "ComboBoxName", "TextBoxName", False, 1) ' Column index 1 ' Multiple Columns, Multi - Value: Call FillTextBoxFromComboBox(Me, "ComboBoxName", "TextBoxName", True, 1) ' Column index 1 مرفق للتجربة Get Value Combo Box Multi Select.accdb

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

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

ياريت مرفق علشان انا فهمى على ادى وانت عارف ده

اولا اعتذر لم انتبه الى رد واجابة والدى الحبيب واستاذى الجليل ومعلمى القدير الاستاذ @ابوخليل يبدو اننى كنت منهمكا فى وضع الاجابة وبعد مشاهدة اجابة والدى الحبيب يبدو انه اعتمد فى الاجابة على تحويل قيم من سنتيمتر إلى twips ولذلك اثراء للموضع الطريقة الثانية اولا ننشئ جدول باسم tblMarginsSettings يحتوى على الجقول الاتية TopMargin (نوع البيانات: Number) BottomMargin (نوع البيانات: Number) LeftMargin (نوع البيانات: Number) RightMargin (نوع البيانات: Number) إنشاء نموذج لإدخال إعدادات الهوامش عناصر التحكم اللازمة لإدخال الهوامش (مربعات نصية) txtTopMargin txtBottomMargin txtLeftMargin txtRightMargin (زر أمر) btnSaveMargins الكود Private Sub btnSaveMargins_Click() ' Ensure only one record in tblMarginsSettings If DCount("*", "tblMarginsSettings") = 0 Then ' If no record, insert a new one DoCmd.RunSQL "INSERT INTO tblMarginsSettings (TopMargin, BottomMargin, LeftMargin, RightMargin) VALUES (" & Me.txtTopMargin & ", " & Me.txtBottomMargin & ", " & Me.txtLeftMargin & ", " & Me.txtRightMargin & ")" Else ' If record exists, update it DoCmd.RunSQL "UPDATE tblMarginsSettings SET TopMargin = " & Me.txtTopMargin & ", BottomMargin = " & Me.txtBottomMargin & ", LeftMargin = " & Me.txtLeftMargin & ", RightMargin = " & Me.txtRightMargin End If MsgBox "Margins settings saved successfully!" End Sub إنشاء الوحدة النمطية لإضافة الدالة العامة الكود Public Function CmToTwips(cm As Double) As Long CmToTwips = cm * 567 End Function وذلك لتحويل القيم من سنتيمتر إلى twips Public Sub SetReportMargins(rpt As Report, _ Optional ByVal DefaultTopCm As Double = 2.54, _ Optional ByVal DefaultBottomCm As Double = 2.54, _ Optional ByVal DefaultLeftCm As Double = 2.54, _ Optional ByVal DefaultRightCm As Double = 2.54) ' Convert default values from cm to twips Dim DefaultTop As Long Dim DefaultBottom As Long Dim DefaultLeft As Long Dim DefaultRight As Long DefaultTop = CmToTwips(DefaultTopCm) DefaultBottom = CmToTwips(DefaultBottomCm) DefaultLeft = CmToTwips(DefaultLeftCm) DefaultRight = CmToTwips(DefaultRightCm) Dim rs As DAO.Recordset On Error GoTo ErrorHandler Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblMarginsSettings") If Not rs.EOF Then rpt.Printer.TopMargin = CmToTwips(Nz(rs!TopMargin, DefaultTopCm)) rpt.Printer.BottomMargin = CmToTwips(Nz(rs!BottomMargin, DefaultBottomCm)) rpt.Printer.LeftMargin = CmToTwips(Nz(rs!LeftMargin, DefaultLeftCm)) rpt.Printer.RightMargin = CmToTwips(Nz(rs!RightMargin, DefaultRightCm)) Else rpt.Printer.TopMargin = DefaultTop rpt.Printer.BottomMargin = DefaultBottom rpt.Printer.LeftMargin = DefaultLeft rpt.Printer.RightMargin = DefaultRight End If rs.Close Set rs = Nothing Exit Sub ErrorHandler: MsgBox "Error setting margins: " & Err.Description If Not rs Is Nothing Then rs.Close Set rs = Nothing End If End Sub على ان يتم الاستدعاء فى التقرير عند فتح التقرير بالشكل التالى Private Sub Report_Open(Cancel As Integer) SetReportMargins Me End Sub

اولا ننشئ جدول باسم tblMarginsSettings يحتوى على الجقول الاتية TopMargin (نوع البيانات: Number) BottomMargin (نوع البيانات: Number) LeftMargin (نوع البيانات: Number) RightMargin (نوع البيانات: Number) إنشاء نموذج لإدخال إعدادات الهوامش عناصر التحكم اللازمة لإدخال الهوامش (مربعات نصية) txtTopMargin txtBottomMargin txtLeftMargin txtRightMargin (زر أمر) btnSaveMargins الكود Private Sub btnSaveMargins_Click() ' Ensure only one record in tblMarginsSettings If DCount("*", "tblMarginsSettings") = 0 Then ' If no record, insert a new one DoCmd.RunSQL "INSERT INTO tblMarginsSettings (TopMargin, BottomMargin, LeftMargin, RightMargin) VALUES (" & Me.txtTopMargin & ", " & Me.txtBottomMargin & ", " & Me.txtLeftMargin & ", " & Me.txtRightMargin & ")" Else ' If record exists, update it DoCmd.RunSQL "UPDATE tblMarginsSettings SET TopMargin = " & Me.txtTopMargin & ", BottomMargin = " & Me.txtBottomMargin & ", LeftMargin = " & Me.txtLeftMargin & ", RightMargin = " & Me.txtRightMargin End If MsgBox "Margins settings saved successfully!" End Sub إنشاء الوحدة النمطية لإضافة الدالة العامة الكود Public Sub SetReportMargins(rpt As Report, _ Optional ByVal DefaultTop As Long = 1440, _ Optional ByVal DefaultBottom As Long = 1440, _ Optional ByVal DefaultLeft As Long = 1440, _ Optional ByVal DefaultRight As Long = 1440) ' Default values are set to 1 inch (1440 twips) which is standard for A4 paper Dim rs As DAO.Recordset On Error GoTo ErrorHandler Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblMarginsSettings") If Not rs.EOF Then rpt.Printer.TopMargin = Nz(rs!TopMargin, DefaultTop) rpt.Printer.BottomMargin = Nz(rs!BottomMargin, DefaultBottom) rpt.Printer.LeftMargin = Nz(rs!LeftMargin, DefaultLeft) rpt.Printer.RightMargin = Nz(rs!RightMargin, DefaultRight) Else rpt.Printer.TopMargin = DefaultTop rpt.Printer.BottomMargin = DefaultBottom rpt.Printer.LeftMargin = DefaultLeft rpt.Printer.RightMargin = DefaultRight End If rs.Close Set rs = Nothing Exit Sub ErrorHandler: MsgBox "Error setting margins: " & Err.Description If Not rs Is Nothing Then rs.Close Set rs = Nothing End If End Sub على ان يتم استدعاءه فى التقرير عندف تح التقرير بالشكل التالى Private Sub Report_Open(Cancel As Integer) SetReportMargins Me End Sub وبذلك يكون هناك مرونة مع المعلمات الافتراضية للدالة SetReportMargins تتيح تحديد هوامش افتراضية في حال عدم وجود قيم في الجدول تم استخدام معايير A4 حيث ان القيم الافتراضية للهوامش تعادل 1 بوصة (1440 twips) لكل جانب وهي مناسبة لمقاسات ورق A4 يمكن استدعاء الدالة من أي تقرير بسهولة باستخدام هذا الكود، ستكون إعدادات الهوامش مرنة وقابلة للتعديل بسهولة، مع التأكد من وجود قيم افتراضية مناسبة عند الحاجة.

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

تحويل الوقت والتاريخ المحلى الي التوقيت عن التوقيت العالمي الموحد (UTC) عرض تاريخ و اوقات دول او مدن مختلفة في نفس الوقت بناء على فرق الوقت بينعم ولين التوقيت العالمي الموحد جدول tblTimeZones والذى يتكون من الحقول ShowInForm : اختيار البلدان للعرض في النموذج CountryName : اسماء المدن و البلدان TimeDifference : فرق التوقيت عن التوقيت العالمي الموحد (UTC) الفارق الزمني (بالساعات، مع إشارة "+" أو "-") DaylightSavingTime : التوقيت الصيفي اولا اكواد الوحدة النمطية Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function GetSystemTimeAPI Lib "kernel32" Alias "GetSystemTime" (lpSystemTime As SYSTEMTIME) As Long #Else Private Declare Function GetSystemTimeAPI Lib "kernel32" Alias "GetSystemTime" (lpSystemTime As SYSTEMTIME) As Long #End If Private Type SYSTEMTIME ' Structure for SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Public Function GetUTC() As Date ' Function to get the current UTC time Dim utctime As Date Dim sysTime As SYSTEMTIME Call GetSystemTime(sysTime) utctime = DateSerial(sysTime.wYear, sysTime.wMonth, sysTime.wDay) + TimeSerial(sysTime.wHour, sysTime.wMinute, sysTime.wSecond) GetUTC = utctime End Function Private Function GetSystemTime(lpSystemTime As SYSTEMTIME) As Long ' Declaration to get system time GetSystemTime = GetSystemTimeAPI(lpSystemTime) End Function هذه الدوال توفر الحصول على الوقت الحالي بالتوقيت العالمي (UTC) SYSTEMTIME هو هيكل يستخدم لتخزين التاريخ والوقت GetSystemTimeAPI هى احد دوال API لـ Windows وظيفتها الحصول على الوقت العالمي (UTC) GetUTC هى دالة تستدعي الدالة GetSystemTimeAPI للحصول على الوقت الحالي بالتوقيت العالمي (UTC) ويتم اعادته كقيمة تاريخ/وقت طيب بعد ذلك الاكواد داخل النموذج النموذج يعرض توقيتات متعددة لدول مختلفة بناء على الاعدادات الموجودة في الجدول tblTimeZone Const FormatDisplayDate As String = "dd/mm/yyyy" Const FormatDisplayTime As String = "hh:mm:ss AM/PM" Const CountDisplayCountry As Integer = 5 Private Sub Form_Load() ' Set the form's timer interval to update every 1 second Me.TimerInterval = 1000 ' Call the function to update times and dates UpdateTimes End Sub Private Sub Form_Timer() ' Call the function to update times and dates when the timer event occurs UpdateTimes End Sub Private Sub UpdateTimes() On Error GoTo ErrorHandler Dim rs As DAO.Recordset Dim utctime As Date Dim i As Integer ' Get the current UTC time utctime = GetUTC() ' Debug.Print "UTC Time: "; utctime ' Open the recordset to fetch data from the tblTimeZones table Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblTimeZones WHERE ShowInForm = True") ' Check if recordset is not empty If Not rs.EOF Then rs.MoveFirst i = 1 ' Loop through each record in the recordset and update the form fields Do While Not rs.EOF And i <= CountDisplayCountry ' Limiting to 5 fields as per your requirement ' Assign values to form fields for each country If FieldExists("txtCountry" & i) Then Me("txtCountry" & i) = rs!CountryName Me("txtTimeDifference" & i) = rs!TimeDifference Me("chkDaylightSavingTime" & i) = rs!DaylightSavingTime ' Adjust time and date based on daylight saving time Dim localTime As Date If rs!DaylightSavingTime Then localTime = DateAdd("h", rs!TimeDifference + 1, utctime) Else localTime = DateAdd("h", rs!TimeDifference, utctime) End If Me("txtTime" & i) = Format(localTime, FormatDisplayTime) Me("txtDate" & i) = Format(localTime, FormatDisplayDate) End If rs.MoveNext i = i + 1 Loop Else ' Display a message if no records found for countries to display 'MsgBox "No countries found to display in the form.", vbExclamation, "No Records" Exit Sub End If ' Close the recordset rs.Close Set rs = Nothing Exit Sub ExitHandler: Exit Sub ErrorHandler: Select Case Err.Number Case 2465 ' Can't find the Object Resume ExitHandler Case Else MsgBox "Error in UpdateTimes: " & Err.Number & vbCrLf & Err.Description, vbExclamation 'Debug.Print Err.Number & " " & Err.Description Resume ExitHandler End Select End Sub Private Function FieldExists(fieldName As String) As Boolean ' Check if a field exists in the form On Error Resume Next FieldExists = (Me(fieldName).Name <> "") On Error GoTo 0 End Function الاعلان عن الثوابت Const FormatDisplayDate : للتحكم فى شكل تسيق التاريخ الذى سوف يتم عرضه Const FormatDisplayTime : للتحكم فى شكل تسيق الوقت الذى سوف يتم عرضه Const CountDisplayCountry : تحديد عدد الدول التى نريد عرض اوقاتها فى النموذج والذى على اساسة ايضا عدد العناصر فى النموذج لهذه البيانات Form_Load: عند تحميل النموذج، يتم تعيين الفاصل الزمني للمؤقت إلى ثانية واحدة ثم يتم استدعاء الدالة UpdateTimes Form_Timer: يتم استدعاء الدالة UpdateTimes كل ثانية لتحديث التوقيتات UpdateTimes وظيفة هذه الدالة هي الحصول على الوقت الحالي بالتوقيت العالمي (UTC) باستخدام الدالة GetUTC فتح مجموعة السجلات من الجدول tblTimeZones لجلب البيانات بناؤ على شرط أن يكون الحقل ShowInForm مضبوطًا على True في حلقة تكرارية يتم تحديث البيانات في العناصر في النموذج بناء على بيانات السجلات مع الأخذ بعين الاعتبار التوقيت الصيفي إذا كان مفعلاً يتم التعامل مع الأخطاء باستخدام كتلة ErrorHandler لضمان عدم تعطل البرنامج بسبب الأخطاء FieldExists: دالة للتحقق مما إذا كان عنصر معين موجودا في النموذج جدول tblTimeZones يحتوي على بيانات عن بلدان مختلفة بما في ذلك فرق التوقيت والتوقيت الصيفي وما إذا كانت البيانات يجب عرضها حيث يتم عرض البلدان المحددة فقط من خلال (ShowInForm = True) في النموذج العناصر فى النموذج كالاتى txtCountry1, txtCountry2, txtCountry3, txtCountry4, txtCountry5 المفروض يتم جلب اسماء البلدان من الجدول هنا ----------------------------------- txtTime1, txtTime2, txtTime3, txtTime4, txtTime5 المفروض يتم عرض التوقيت المحلى لكل بلد هنا ----------------------------------- txtTimeDifference1, txtTimeDifference2, txtTimeDifference3, txtTimeDifference4, txtTimeDifference5 المفروض يتم جلب الفرق في التوقيت لكل بلد هنا ----------------------------------- chkDaylightSavingTime1, chkDaylightSavingTime2, chkDaylightSavingTime3, chkDaylightSavingTime4, chkDaylightSavingTime5 المفروض يتم عرض ان كان التوقيت الصيفي مفعلا ام لا هنا ----------------------------------- txtDate1, txtDate2, txtDate3, txtDate4, txtDate5 المفروض يتم عرض التاريخ طبقا للتوقيت المحلى لكل بلد هنا ----------------------------------- المفروض كل ذلك يحدث من خلال الكود بمجرد فتح النموذج بطريقة الية والشرط طبعا هو جلب البيانات بناء على البلدان المختارة عرض بيناتها من خلال اختيارها من الحقل ShowInForm واخيرا المرفقات المرفق الاول وهو الاساس والذى تم استعراض الافكار والاكواد السابقة طبقا له المرفق الثانى فقط تم اضافة عدد نماذج لساعات على ان تكون نماذج فرعية TimeZones.zip TimeZones UP 2.zip

المرفق الثانى TimeZones UP 2.zip

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

المرفق الأول البسيط TimeZones.accdb

جارى تحضير مقاجأه

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

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

تدلل انشئ موديول واعطه مثلا الاسم basResizeControls وضع به الكود الاتى Option Compare Database Option Explicit ' Constants Const FONT_ZOOM_PERCENT_CHANGE As Double = 0.1 ' Percentage change for font zoom ' Variables Private fontZoom As Double ' Current font zoom level Private ctrlKeyIsPressed As Boolean ' Flag to indicate if the Ctrl key is pressed ' Enum to represent control tag indices Private Enum ControlTag FromLeft = 0 FromTop ControlWidth ControlHeight OriginalFontSize OriginalControlHeight End Enum ' Log error message to debug or a specified location Private Sub LogError(errMsg As String) ' Modify this part to log errors as needed, e.g., in a table or text file Debug.Print "Error: " & errMsg End Sub ' Save control positions to their Tag properties Public Sub SaveControlPositionsToTags(frm As Form) On Error GoTo ErrorHandler Dim ctl As Control Dim ctlLeft As String Dim ctlTop As String Dim ctlWidth As String Dim ctlHeight As String Dim ctlOriginalFontSize As String Dim ctlOriginalControlHeight As String For Each ctl In frm.Controls ctlLeft = CStr(Round(ctl.Left / frm.Width, 2)) ' Calculate relative left position ctlTop = CStr(Round(ctl.Top / frm.Section(ctl.Section).Height, 2)) ' Calculate relative top position ctlWidth = CStr(Round(ctl.Width / frm.Width, 2)) ' Calculate relative width ctlHeight = CStr(Round(ctl.Height / frm.Section(ctl.Section).Height, 2)) ' Calculate relative height ' Capture original font size and control height for specific control types Select Case ctl.ControlType Case acLabel, acCommandButton, acTextBox, acComboBox, acListBox, acTabCtl, acToggleButton ctlOriginalFontSize = ctl.FontSize ctlOriginalControlHeight = ctl.Height End Select ' Store the calculated values in the Tag property ctl.Tag = ctlLeft & ":" & ctlTop & ":" & ctlWidth & ":" & ctlHeight & ":" & ctlOriginalFontSize & ":" & ctlOriginalControlHeight Next ' Store proportional heights for header and footer sections frm.Section(acHeader).Tag = CStr(Round(frm.Section(acHeader).Height / (frm.Section(acHeader).Height + frm.Section(acDetail).Height + frm.Section(acFooter).Height), 2)) frm.Section(acFooter).Tag = CStr(Round(frm.Section(acFooter).Height / (frm.Section(acHeader).Height + frm.Section(acDetail).Height + frm.Section(acFooter).Height), 2)) Exit Sub ErrorHandler: LogError "SaveControlPositionsToTags: " & Err.Description Resume Next End Sub ' Reposition controls based on their stored Tag properties and current font zoom Public Sub RepositionControls(frm As Form, fontZoom As Double) On Error GoTo ErrorHandler Dim formDetailHeight As Long Dim tagArray() As String ' Calculate the detail section height formDetailHeight = frm.WindowHeight - frm.Section(acHeader).Height - frm.Section(acFooter).Height Dim ctl As Control For Each ctl In frm.Controls If ctl.Tag <> "" Then tagArray = Split(ctl.Tag, ":") ' Split the Tag property into an array If ctl.Section = acDetail Then ctl.Move frm.WindowWidth * CDbl(tagArray(ControlTag.FromLeft)), _ formDetailHeight * CDbl(tagArray(ControlTag.FromTop)), _ frm.WindowWidth * CDbl(tagArray(ControlTag.ControlWidth)), _ formDetailHeight * CDbl(tagArray(ControlTag.ControlHeight)) Else ctl.Move frm.WindowWidth * CDbl(tagArray(ControlTag.FromLeft)), _ frm.Section(ctl.Section).Height * CDbl(tagArray(ControlTag.FromTop)), _ frm.WindowWidth * CDbl(tagArray(ControlTag.ControlWidth)), _ frm.Section(ctl.Section).Height * CDbl(tagArray(ControlTag.ControlHeight)) End If ' Adjust font sizes for specific control types Select Case ctl.ControlType Case acLabel, acCommandButton, acTextBox, acComboBox, acListBox, acTabCtl, acToggleButton ctl.FontSize = Round(CDbl(tagArray(ControlTag.OriginalFontSize)) * (ctl.Height / CDbl(tagArray(ControlTag.OriginalControlHeight))) * fontZoom) End Select End If Next Exit Sub ErrorHandler: LogError "RepositionControls: " & Err.Description Resume Next End Sub ' Initialize the form by saving control positions Public Sub InitForm(frm As Form) On Error GoTo ErrorHandler fontZoom = 1 ' Set initial font zoom level SaveControlPositionsToTags frm Exit Sub ErrorHandler: LogError "InitForm: " & Err.Description Resume Next End Sub ' Handle the mouse wheel event to zoom in/out if Ctrl key is pressed Public Sub HandleMouseWheel(frm As Form, ByVal Page As Boolean, ByVal Count As Long) On Error GoTo ErrorHandler If ctrlKeyIsPressed Then If Count < 0 Then fontZoom = fontZoom + FONT_ZOOM_PERCENT_CHANGE ' Increase font zoom RepositionControls frm, fontZoom ElseIf Count > 0 Then fontZoom = fontZoom - FONT_ZOOM_PERCENT_CHANGE ' Decrease font zoom RepositionControls frm, fontZoom End If End If Exit Sub ErrorHandler: LogError "HandleMouseWheel: " & Err.Description Resume Next End Sub ' Handle the form resize event Public Sub HandleResize(frm As Form) On Error GoTo ErrorHandler ' Adjust header and footer heights proportionally frm.Section(acHeader).Height = frm.WindowHeight * CDbl(frm.Section(acHeader).Tag) frm.Section(acFooter).Height = frm.WindowHeight * CDbl(frm.Section(acFooter).Tag) RepositionControls frm, fontZoom Exit Sub ErrorHandler: LogError "HandleResize: " & Err.Description Resume Next End Sub ' Handle key up event to reset Ctrl key flag Public Sub HandleKeyUp() ctrlKeyIsPressed = False End Sub ' Handle key down event to manage font zooming with + and - keys Public Sub HandleKeyDown(frm As Form, KeyCode As Integer, Shift As Integer) On Error GoTo ErrorHandler Dim shiftKeyPressed As Boolean shiftKeyPressed = (Shift And acShiftMask) > 0 If shiftKeyPressed Then Select Case KeyCode Case vbKeyAdd fontZoom = fontZoom + FONT_ZOOM_PERCENT_CHANGE ' Increase font zoom RepositionControls frm, fontZoom KeyCode = 0 ' Prevent the "+" symbol from showing up in text boxes Case vbKeySubtract fontZoom = fontZoom - FONT_ZOOM_PERCENT_CHANGE ' Decrease font zoom RepositionControls frm, fontZoom KeyCode = 0 ' Prevent the "-" symbol from showing up in text boxes End Select End If ' Check if Ctrl key is pressed If (Shift And acCtrlMask) > 0 Then ctrlKeyIsPressed = True End If Exit Sub ErrorHandler: LogError "HandleKeyDown: " & Err.Description Resume Next End Sub وفى النموذج يتم الاستدعاء من خلال Private Sub Form_Load() Call InitForm(Me) End Sub Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long) Call HandleMouseWheel(Me, Page, Count) End Sub Private Sub Form_Resize() Call HandleResize(Me) End Sub Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) Call HandleKeyUp End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Call HandleKeyDown(Me, KeyCode, Shift) End Sub وان اردت اضافة DoCmd.Maximize فى الحدث Form_Load يمكنك ذلك

يمكنكم الاطلاع على هذا المرفق https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=129345