ابو جودي

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

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

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

اولا اعتذر لم انتبه الى رد واجابة والدى الحبيب واستاذى الجليل ومعلمى القدير الاستاذ @ابوخليل يبدو اننى كنت منهمكا فى وضع الاجابة وبعد مشاهدة اجابة والدى الحبيب يبدو انه اعتمد فى الاجابة على تحويل قيم من سنتيمتر إلى 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

ولان تعليقى بعد تقديم حلول اساتذتى الكرام لك اعتقد انه كان صادما ولانه اذا عرف السبب بطل العجب اليك السبب انظر الى قاعدة البيانات الاتية بعد اغلاقك لمفتاح الشيفت فى قاعدتك يمكن تغيير الاعداد مرة اخرى لقاعدتك من خلال المرفق الاتى فيتم استعادة عمل زر الشيفت مرة أخرى Security(Enable-Disable Shift Key).accdb

اتفضل موضوع بالشرح اتمنى ان يفى بالغرض

السلام عليكم ورحمة الله تعالى وبركاته بعد مواجهتى لمشكلة فى هذه النقطة عند التعامل مع ملفات الاكسل بسبب اختلاف النسخ والتنسيق لملفات الاكسل تبعا لاختلاف الاصدارات كانت هذه نتيجة وخلاصة افكاارى لحل مشاكلى اليكم الخطوات 1- انشاء وحدة نمطية عامة ليسهل استدعاء الدوال منها فى شتى زوايا التطبيق واعطائها الاسم التالى basFileUtilityKit بها هذه الكود Option Compare Database Option Explicit ' Enumeration for the types of file dialogs Enum EnumFileDialogType msoFileDialogFilePicker = 1 msoFileDialogFolderPicker = 4 End Enum ' Enumeration for different file extensions Enum EnumFileExtensions AccessFiles ExcelFiles WordFiles PDFFiles TextFiles ImageFiles VideoFiles AudioFiles AllFiles ' You can add additional file extensions as needed here End Enum ' Enumeration for different options related to file paths Enum EnumOptionFile DirectoryWithoutFileName DirectoryWithFileName FileNameWithExtension FileNameWithoutExtension ExtensionOnly End Enum ' Function to open the folder dialog and return the selected folder path Function GetFolderDialog() As String On Error Resume Next Dim folderDialogObject As Object Set folderDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFolderPicker) With folderDialogObject .Title = "Select Folder" .AllowMultiSelect = False .Show End With If folderDialogObject.SelectedItems.Count > 0 Then GetFolderDialog = folderDialogObject.SelectedItems(1) Else ' Handle the case where no folder is selected MsgBox "No folder selected.", vbExclamation GetFolderDialog = "" End If Set folderDialogObject = Nothing On Error GoTo 0 End Function ' Function to open the file dialog and return the selected file path Function GetFileDialog(ByVal EnumFileExtension As EnumFileExtensions) As String On Error Resume Next ' Check if the Microsoft Office Object Library is referenced ' Make sure to go to Tools > References and select the appropriate version ' e.g., "Microsoft Office 16.0 Object Library" for Office 2016 Dim fileDialogObject As Object Set fileDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFilePicker) With fileDialogObject .Title = "Select File" .AllowMultiSelect = False .Filters.Clear ' Adding filters based on the selected file extension Select Case EnumFileExtension Case EnumFileExtensions.AllFiles .Filters.Add "All Files", "*.*" Case EnumFileExtensions.TextFiles .Filters.Add "Text Files", "*.txt" Case EnumFileExtensions.ExcelFiles .Filters.Add "Excel Files", "*.xlsx; *.xls" Case EnumFileExtensions.ImageFiles .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.gif" Case EnumFileExtensions.VideoFiles .Filters.Add "Video Files", "*.mp4; *.avi; *.mov" Case EnumFileExtensions.AudioFiles .Filters.Add "Audio Files", "*.mp3; *.wav; *.ogg" Case EnumFileExtensions.PDFFiles .Filters.Add "PDF Files", "*.pdf" Case EnumFileExtensions.WordFiles .Filters.Add "Word Files", "*.docx; *.doc" Case EnumFileExtensions.AccessFiles .Filters.Add "Word Files", "*.accda , *.accdb,*.accdc , *.accde,*.accdr , *.accdt,*.accdw , *.mda,*.mdb , *.mde,*.mdf , *.mdw" ' You can add additional file extensions as needed here End Select .Show End With If fileDialogObject.SelectedItems.Count > 0 Then GetFileDialog = fileDialogObject.SelectedItems(1) Else ' Handle the case where no file is selected MsgBox "No file selected.", vbExclamation GetFileDialog = "" End If Set fileDialogObject = Nothing Exit Function If Err.Number <> 0 Then Select Case Err.Number Case 3078: Resume Next ' Ignore error if user cancels the file dialog Case 0: Resume Next Case Else ' Call ErrorLog(Err.Number, Error$, strProcessName) End Select ' Clear the error Err.Clear End If End Function ' Function to get the desired option for a file path Function GetFileOption(ByRef strFilePath As String, Optional ByRef EnumOptionFile As EnumOptionFile = DirectoryWithFileName) As String On Error Resume Next Select Case EnumOptionFile Case DirectoryWithoutFileName GetFileOption = Left(strFilePath, InStrRev(strFilePath, "\")) Case DirectoryWithFileName GetFileOption = strFilePath Case FileNameWithExtension GetFileOption = Mid(strFilePath, InStrRev(strFilePath, "\") + 1) Case ExtensionOnly GetFileOption = Right(strFilePath, Len(strFilePath) - InStrRev(strFilePath, ".")) Case FileNameWithoutExtension GetFileOption = Mid(strFilePath, InStrRev(strFilePath, "\") + 1, InStrRev(strFilePath, ".") - InStrRev(strFilePath, "\") - 1) End Select On Error GoTo 0 End Function ' Function to get additional information about a file Function GetFileInfo(filePath As String) As String On Error Resume Next Dim fileInfo As String fileInfo = "File Information:" & vbCrLf fileInfo = fileInfo & "Path: " & filePath & vbCrLf fileInfo = fileInfo & "Size: " & FileLen(filePath) & " bytes" & vbCrLf fileInfo = fileInfo & "Created: " & FileDateTime(filePath) & vbCrLf GetFileInfo = fileInfo On Error GoTo 0 End Function شرح الوظائف فى هذه الوحدة النمطية Enumerations توفر طريقة لتعريف مجموعة من الثوابت التي يمكن استخدامها لتحديد أنواع معينة من القيم. EnumFileDialogType هذه الـ Enumeration تستخدم لتحديد نوع مربع الحوار الخاص بالملفات: msoFileDialogFilePicker: لفتح مربع حوار لاختيار الملفات. msoFileDialogFolderPicker: لفتح مربع حوار لاختيار المجلدات. EnumFileExtensions هذه الـ Enumeration تستخدم لتحديد نوع الامتدادات التي يمكن اختيارها من مربع حوار الملفات: AllFiles: جميع الملفات. TextFiles: ملفات النصوص. ExcelFiles: ملفات إكسل. ImageFiles: ملفات الصور. VideoFiles: ملفات الفيديو. AudioFiles: ملفات الصوت. PDFFiles: ملفات PDF. WordFiles: ملفات وورد. EnumOptionFile هذه الـ Enumeration تستخدم لتحديد الخيارات المختلفة المتعلقة بالمسارات: DirectoryWithoutFileName: المسار بدون اسم الملف. DirectoryWithFileName: المسار مع اسم الملف. FileNameWithExtension: اسم الملف مع الامتداد. FileNameWithoutExtension: اسم الملف بدون الامتداد. ExtensionOnly: الامتداد فقط. Functions GetFolderDialog هذه الدالة تفتح مربع حوار لاختيار المجلدات وتعيد المسار الكامل للمجلد الذي تم اختياره. إذا لم يتم اختيار أي مجلد، تعرض رسالة تنبيه وتعيد قيمة فارغة. GetFileDialog هذه الدالة تفتح مربع حوار لاختيار الملفات وتعيد المسار الكامل للملف الذي تم اختياره. يمكنك تحديد نوع الملفات المسموح باختيارها عبر الـ EnumFileExtensions. إذا لم يتم اختيار أي ملف، تعرض رسالة تنبيه وتعيد قيمة فارغة. GetFileOption هذه الدالة تستخدم لتحديد أجزاء معينة من مسار الملف بناءً على القيمة المحددة في الـ EnumOptionFile: DirectoryWithoutFileName: يعيد المسار بدون اسم الملف. DirectoryWithFileName: يعيد المسار مع اسم الملف. FileNameWithExtension: يعيد اسم الملف مع الامتداد. FileNameWithoutExtension: يعيد اسم الملف بدون الامتداد. ExtensionOnly: يعيد الامتداد فقط GetFileInfo هذه الدالة تعيد معلومات حول ملف محدد، بما في ذلك المسار، الحجم، وتاريخ الإنشاء. تعرض هذه المعلومات كجزء من نص مرتجع. ------------------------ 2- انشاء وحدة نمطية عامة ليسهل استدعاء الدوال منها فى شتى زوايا التطبيق واعطائها الاسم التالى basExcelDataImport بها هذه الكود Public Const strTableExcel As String = "tblImportExcel" Function ExcelDataImport(ByRef excelFilePath As String) On Error Resume Next ' Disable error handling temporarily Const xlOpenXMLWorkbook As Long = 51 ' Variables for Excel and Access Dim excelApp As Object Dim excelWorkbook As Object Dim excelOpened As Boolean Dim sourceFileName As String Dim mainDirectory As String Dim convertedExcelFilePath As String ' Check if the Excel file path is provided If Nz(excelFilePath, "") = "" Then Exit Function ' Check if the Excel file exists If Dir(excelFilePath) = "" Then Exit Function ' Extract file information sourceFileName = GetFileOption(excelFilePath, FileNameWithExtension) mainDirectory = GetFileOption(excelFilePath, DirectoryWithoutFileName) convertedExcelFilePath = excelFilePath ' Create Excel application object Set excelApp = CreateObject("Excel.Application") ' Check if Excel application is successfully created If Err.Number <> 0 Then Err.Clear Set excelApp = CreateObject("Excel.Application") excelOpened = False Else excelOpened = True End If ' Reset error handling On Error GoTo 0 ' Set Excel application visibility excelApp.Visible = False ' Open Excel workbook Set excelWorkbook = excelApp.Workbooks.Open(mainDirectory & sourceFileName) ' Save the workbook in xlsx format without displaying alerts excelApp.DisplayAlerts = False excelWorkbook.SaveAs Replace(mainDirectory & sourceFileName, ".xls", ".xlsx"), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False excelApp.DisplayAlerts = True ' Close the workbook without saving changes excelWorkbook.Close False ' Quit Excel application if it was opened by the function If excelOpened = True Then excelApp.Quit ' Update the source file name with the new extension sourceFileName = sourceFileName & "x" ' Reset file attributes SetAttr mainDirectory & sourceFileName, vbNormal ' Import Excel data into Access table DoCmd.SetWarnings False 'acSpreadsheetTypeExcel8 DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, strTableExcel, mainDirectory & sourceFileName, True ExitFunction: ' Enable system alerts before exiting the function DoCmd.SetWarnings True Exit Function ErrorHandler: ' Handle errors Select Case Err.Number Case 3078: Resume Next ' Ignore error if user cancels the file dialog Case 0: Resume Next Case Else ' Call ErrorLog(Err.Number, Error$, strProcessName) End Select End Function ' Function to delete all records from the specified table Sub DeleteAllRecords(Optional ByRef strTable As String = "") On Error Resume Next If Nz(strTable, "") = "" Then strTable = strTableExcel CurrentDb.Execute "DELETE FROM " & strTable ' Handle errors Select Case Err.Number Case 3078 If strTable = strTableExcel Then Resume Next Else Case Else ' HandleAndLogError strProcessName End Select End Sub شرح الوظائف فى هذه الوحدة النمطية الدالة ExcelDataImport تستورد بيانات من ملف Excel إلى جدول في قاعدة بيانات Access. strTableExcel: ثابت يحدد اسم الجدول في قاعدة بيانات Access الذي سيتم استيراد بيانات Excel إليه. excelFilePath: مسار ملف Excel الذي سيتم استيراد البيانات منه. ------------------------ 3- انشاء نموذج وفى الحدث عند النقر على زر الامر استخدم الكود التالى Private Sub cmdSubmit_Click() ' Get the path of the Excel file Dim strFilePath As String strFilePath = GetFileDialog(EnumFileExtensions.ExcelFiles) ' Check if a file was selected If strFilePath <> "Cancelled" Then ' Show status label Me!lblStatus.Visible = True Me!lblStatus.Caption = "Please wait ... " ' Clear TableData DeleteAllRecords ' Import data from Excel ExcelDataImport strFilePath ' Add Or Update Yor Table ' Hide the status label or reset any visual indicator Me!lblStatus.Visible = False Else ' User canceled the file selection MsgBox "File selection canceled", vbExclamation End If End Sub الان يتبقى عمل الاستعلام اللازم لاضاقة او تحديث وتعديل بياناتك طبقا لجدول الاكسس حسب رغباتك وتطلعاتك واخيرا مرفق قاعدة البيانات ImportFromExel.accdb

الحمد لله رب العالمين سعيد لسماع ذلك يسعدني انه تم حل مشكلتك

لا توجد اى طريقة ريح نفسك طريقك مسدود مسدود يا ولدى

اتفضل جرب استيراد البيانات من خلال نموذج Form1 من خلال الضغط على الزر واستعراض المجلدات لاختيار ملف الاكسل المراد استيراد البيانات منه سوف يتم انشاء جدول مؤقت به البيانات انقلها بعد ذلك للجدول وقم بباقى العمليات التى تريد اجراءها كما بحلو لك test ExcelDataImport.rar

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

لابد من إعادة تثبيت Microsoft Access

اهاااااا والان حضر الوحش صاحب المكتبة العامرة الاستاذ @Moosak اراه الان بعد ان اضاف المرفق الى مكتبته العامرة يتفحص ويمحص ترى هل يجد الثغرة ويتغلب عليها ؟!

جملة SQL هذه تهدف إلى حذف سجل او سجلات محددة من جدول معين وتحديداحذف السجلات التي يكون فيها قيمة الحقل "id" مساوية للقيمة المخزنة في المتغير "x"