ابو جودي

اعتذر عن الانقطاع لظروف مرضية ان شاء الله سوف نبدأ فى الاستمرار تباعا بامر الله

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

لا شكر على واجب اهلا بك جزانا والله واياكم خير الجزاء وسعيد جدا والله الحمد انا فى حد بتعجبة شخابيطى وعلشان بتحب الشخبطة خد اخر شخابيطى توسيط واخفاء بطريقة جديدة HideAccess.accdb

للاسف مع الاخفاء لابد من ان تكون Pou Up = yes Modal = YES لكل النماذج والتقارير ولا انصحك باعتماد كود اخفاء اطار الاكسس هذا

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

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

لو لاحظت انا كتبت الدالة الاولى وحتكون ثابته على طول لاى جدول ولاى معايير الدالة التانية بس للاستدعاء كل ما عليك تكتب اسم الجدول والحقل والمعيار وتختار ان كان رقمى او نصى او تاريخ واللذيذ ان فى مصفوفة بتجيب لك كل الحقول يعنى تعرف متغير result ويكون مصدر بيانات الحقل result(i) طبعا لو فى عمليات حسابية معقدة داخل الكود تكون اسرع من الاستعلام لو استخدمت فيه دوال المجال وفى الاخير انت الان معاك اكثر من طريقة

على طريقة المعقدين امثالى اعمل مديول ضع الوظيفة الاتية Enum TypeWHERE asString asDate asNumeric End Enum Dim rsArryFieldName As Variant Function RetrieveData(ByRef tableName As String, _ ByRef fieldName As String, _ Optional varMyWHERE As Variant = "", _ Optional TypeMyWHERE As TypeWHERE = TypeWHERE.asString, _ Optional LinkCriteria As String = "") As Variant ' This function retrieves data from the specified table and field based on the provided criteria. ' Translate the criteria type to the appropriate SQL syntax Select Case TypeMyWHERE Case TypeWHERE.asDate LinkCriteria = "[" & fieldName & "] = #" & varMyWHERE & "#" '| Date Case TypeWHERE.asNumeric LinkCriteria = "[" & fieldName & "] = " & varMyWHERE '| Numeric Case TypeWHERE.asString LinkCriteria = "[" & fieldName & "] = '" & varMyWHERE & "'" '| String End Select ' Declare a DAO Recordset variable Dim rs As DAO.Recordset ' Open a recordset based on the provided table and field names Set rs = CurrentDb.OpenRecordset("SELECT * FROM " & tableName & " WHERE " & LinkCriteria) ' Check if the recordset is not empty If Not rs.EOF Then ' Create an array to hold values of all fields in the record Dim fieldValues() As Variant ReDim fieldValues(1 To rs.fields.Count) Dim i As Integer ' Populate the array with values from all fields For i = 1 To rs.fields.Count fieldValues(i) = rs.fields(i - 1).Value Next i ' Return the array containing values of all fields RetrieveData = fieldValues Else ' Return an empty string if no matching record is found RetrieveData = "" End If ' Close the recordset rs.Close Set rs = Nothing End Function وشوف التجربة من خلال هذا الروتين Sub ExampleUsage() ' Set the table name and field name Dim tableName As String Dim fieldName As String Dim criteriaValue As Variant Dim criteriaType As TypeWHERE ' Set default values tableName = "YourTableName" ' | << Set the table name fieldName = "YourFieldName" ' | << Set the field name criteriaValue = "YourCriteriaValue" ' | << Set Your Criteria Value criteriaType = TypeWHERE.asString ' | << Set the type of criteria and You can change it based on the case type of criteria ' Call the RetrieveData procedure Dim result As Variant result = RetrieveData(tableName, fieldName, criteriaValue, criteriaType) ' Display values of all fields in the array If IsArray(result) Then Dim i As Integer For i = 1 To UBound(result) Debug.Print i & ": " & result(i) Next i ' Display the value of field number 3 (For example, EmployeeName) Debug.Print result(3) Else ' If no matching record is found, show an appropriate message MsgBox "No matching record found for the specified criteria." End If End Sub وعيش مع الكود ومع بنات افكارك

طبعا لا يفتى ومالك فى المدينة اممم تصدق مش عارف اقول اه واللا لاء بس بعد الشرح ده انت قول الاجابة دوال المجـــــــ(Domain Functions)ـــــــــال جزءا من مجموعة من الدوال التي تستخدم للتلاعب بالبيانات في قاعدة البيانات وهى ليست استعلامات هذه الدوال تعتبر جزءا من استعلامات SQL (Structured Query Language) التي تستخدم لاسترجاع وتحديث البيانات دوال المجال تسمح لك بتنفيذ عمليات معينة على البيانات في حقل معين من جدول معين على سبيل المثال : - يمكن استخدام دالة المجال Dlookup للبحث عن قيمة في حقل محدد بناء على شرط معين او عدة شروط هذه الدوال تستخدم ضمن تعبيرات SQL داخل استعلامات يعنى خى ليست استعلامات انما هى تستخدم كجزء داخل الاستعلامات Dlookup >>----> للبحث عن قيمة في حقل معين DCount >>----> لحساب عدد السجلات التي تستوفي شرط محدد DSum >>----> لحساب مجموع قيم حقل معين بناءً على شرط يبقى الاجابة ايه

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

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

على سبيل المثال #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Public Function SendWhatsAppMsg(toNumber As String, Optional Msg As String, Optional FilePathh As String) Dim IE As Object Set IE = CreateObject("InternetExplorer.Application") IE.Visible = False IE.Navigate "whatsapp://send?phone=" & toNumber & "&Text=" & Nz(Msg, "") Sleep 2000 If Len(FilePathh) > 5 Then SendKeys "+{TAB}" SendKeys "~" Sleep 2000 SendKeys "{UP}" SendKeys "{UP}" SendKeys "~" Sleep 2000 SendKeys Nz(FilePathh, "") SendKeys "~" Sleep 3000 Else 'MsgBox "No" End If SendKeys "~" SendKeys "{NUMLOCK}", True Set IE = Nothing End Function هذا الكود يستخدم VBA لفتح WhatsApp Web (WhatsApp عبر المتصفح) وإرسال رسالة نصية أو رسائل معينة تعتمد هذه الطريقة على استخدام إطار الإنترنت (InternetExplorer.Application) لفتح WhatsApp Web ومحاكاة إرسال الرسائل باستخدام SendKeys. ومع ذلك، يجب أن ألفت انتباهكم إلى أن استخدام SendKeys يعتبر طريقة غير موثوقة وقد تتعرض للمشاكل في بيئات مختلفة تعتمد هذه الطريقة على تحكم البرنامج في العناصر التفاعلية في واجهة المستخدم وهو شيء قد يتغير في التحديثات المستقبلية لتطبيقات المتصفح وبالفعل تم وقف التعامل مع هذا المتصفح نهائيا فى تحديثات ونسخ الويندوز الحديثة فأصبح غير معتمد نهائيا إذا كنتم بحاجة إلى التفاعل مع واتساب بشكل برمجي يمكن الأفضل استخدام واجهة برمجة تطبيقات WhatsApp Business API ولكن هذا يتطلب تسجيلًا كشركة واستخدامه لأغراض الأعمال

للاسف مشكلة اى تطبيقات تعمد على وسيط قد تعمل عند البعض ولا تعمل عند اخرين ويرجع ذلك الى اصدارات الوسطاء السبب ان التطبيق يقوم بارسال البيانات عبر دوال للمتصفحات او للتطبيق ومع التحديثات التى تصل الى الويندوز او جوجل كروم او باقى المتصفحات قد تحدث تتغيرات تعود بالسلب على مثل هذه التطبيقات لذلك لا احب استعمال اى وسطاء .. الوسطاء يمتنعون لا يمكن إرسال رسائل WhatsApp من خلال VBA مباشرة باستخدام WhatsApp Desktop أو WhatsApp Web يتم استخدام WhatsApp Desktop و WhatsApp Web للتفاعل مع رقم هاتف مرتبط بحساب WhatsApp على هاتفك المحمول يمكنك التفاعل مع WhatsApp عبر الحوارات النصية والوسائط والمزيد من خلال تلك الوسائل ولكن الوصول إلى واجهة برمجة التطبيقات (API) الخاصة بـ WhatsApp مباشرةً لا يزال مقيدًا ويتم حاليًا توفير واجهة برمجة تطبيقات (API) WhatsApp Business API لأغراض الأعمال إذا كنتم بحاجة إلى التفاعل مع WhatsApp من خلال VBA يمكنك استخدام تقنيات أخرى مثل استخدام السيرفرات الوسيطة والتي تتيح لك التحكم في التطبيق من خلال البرمجة (على الرغم من أن هذا قد يتطلب إعدادات متقدمة والتى لن يكون مسموحًا به أصلا ً من قبل WhatsApp) وذلك بسبب سياسات WhatsApp وشروط الاستخدام الخاصة بها

وممكن SELECT VAL([ID]) AS valID, * FROM tblEmployees WHERE VAL([ID]) BETWEEN 50 AND 80; وممكن استخدام دالة CDBL لتحويل إلى رقم مزدوج (Double): SELECT CDBL([ID]) AS cdblID, * FROM tblEmployees WHERE CDBL([ID]) BETWEEN 50 AND 80; وممكن استخدام دالة CDATE للتحويل إلى تاريخ (إذا كان يمكن تفسير القيم كتواريخ) SELECT CDATE([FieldName]) AS cdateFieldName, * FROM TableName WHERE CDATE([FieldName]) Between #50# And #80#;

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

ولو الحقل كان نصى وانت كاتب فيه ارقام استخدم الاستعلام بالشكل التالى SELECT CLng([FieldName]) AS clngFieldName, * FROM TableName WHERE (((CLng([FieldName])) Between CLng(50) And CLng(80)));

وبناء على قول استاذى الجليل ومعلمى القدير الاستاذ @شايب استخدم هذه الطريقة افضل من خلال استعلام SELECT * FROM TableName WHERE FieldName BETWEEN 50 AND 80;

صباح الخيرات كان يسأل عنه من قبل بعض الاخوة الاحباب

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

لتصميم الشاشة الرئيسية وسهولة التحكم فىيها تم اضافة جدول جديد باسم tblFormsTitle يتكون من الحقول FormName = اسم النموذج الفرعى FormDesc = وصف النموذج ( معيار احضار بيانات اسم النموذج والعنوان فى الكود) TitleForm = العنوان فى الشاشة الرئيسية البيانات داخل الجدول كالاتى اسم النموذج الفرعى وصف النموذج ( معيار احضار بيانات اسم النموذج والعنوان فى الكود) العنوان فى الشاشة الرئيسية frmHomeMenu HomeMenu الرئيسية frmSub1ImportOraclExcel ImportExcel استيراد بيانات الحضور والانصراف ( Oracle's Excel sheet ) frmSub2DailyEmployee DailyEmployee ادارة يوميات الموظفين ( اضافة / تعديل / حذف ) frmSub3QueryDaily QueryDailyBy استعلام وتقارير يوميات الموظفين frmSub4Employees EmployeesData ادارة بيانات الموظفين ( اضافة / تعديل / حذف ) frmSub5DailyLogsType DailyLogsType ادارة انواع اليوميات ( اضافة / تعديل / حذف ) frmSub6Department Department ادارة بيانات الادارات و المديرين ( اضافة / تعديل / حذف ) frmSub7Section Section ادارة بيانات الاقسام ( اضافة / تعديل / حذف ) تم تصميم النماذج الفرعية بدون اى مصدر بيانات .... عمل نموذج رئيسي باسم frmMain فى وضع التصميم تم اضافة نموذج فرعى غير منضم باسم subformControl تم اضافة مربع تسمية ( Lable ) باسم lblTitle اضافة عدد سبع ازرار باسماء btnNavItem1 ,btnNavItem2 , btnNavItem3 , ........ الخ عنصر تحكم صورة باسم imgArrow يحتوى على شكل سهم الاكواد فى النموذج قائمة بوظائف الازرار تبعا لوصف النماذج من الجدول والذى اشرنا الى الحقل الخاص به وصف النموذج ( معيار احضار بيانات اسم النموذج والعنوان فى الكود) ' Enum to define button actions Enum ButtonAction HomeMenu ImportExcel DailyEmployee QueryDailyBy EmployeesData DailyLogsType Department Section End Enum متغيرات لاسناد قيم اليها ' Declare variables to store form name and title Private strFormName As String Private strTitleForm As String Private subformInfoArray As Variant دالة لتحديد المعيار لجلب البيانات للنماذج الفرعية من الجدول ( اسم النموذج - العنوان فى الشاشة الرئيسية ) بناء على Enum قائمة الازرار ' Sub to handle button click events Private Sub HandleButtonClick(btnAction As ButtonAction) Dim subformInfoResult As String ' Get subform information based on the button action subformInfoResult = GetSubformInfo(ButtonActionToString(btnAction)) ' Process the subform information and update the form ProcessSubformInfo subformInfoResult End Sub دالة لاحضار معلومات النماذج الفرعية من الجدول ( اسم النموذج - العنوان فى الشاشة الرئيسية ) بناء على المعيار من الدالة السابقة ' Function to get the name and title of the subform based on the form description Function GetSubformInfo(subformDesc As String) As String ' Use On Error Resume Next to handle errors gracefully On Error Resume Next ' Declare a DAO Recordset variable Dim rs As DAO.Recordset ' Open a recordset based on the provided form description Set rs = CurrentDb.OpenRecordset("SELECT FormName, TitleForm FROM tblFormsTitle WHERE FormDesc='" & subformDesc & "'") ' Check if the recordset is not empty If Not rs.EOF Then ' Return the concatenated string of FormName and TitleForm GetSubformInfo = rs!formName & "," & rs!titleForm Else ' Return an empty string if no matching record is found GetSubformInfo = "" End If ' Close the recordset to free up resources rs.Close Set rs = Nothing ' Check for errors and display debug information If Err.Number <> 0 Then MsgBox "Error retrieving subform information: " & Err.Description, vbExclamation Err.Clear End If End Function دالة لفصل اسم النموذج والعنوان والذى تم الحصول عليهم من الدالة السابقة ' Sub to process subform information and update the form Sub ProcessSubformInfo(subformInfoResult As String) ' Split the subformInfo into an array subformInfoArray = Split(subformInfoResult, ",") ' Extract the formName and title from the array If UBound(subformInfoArray) >= 1 Then strFormName = Trim(subformInfoArray(0)) strTitleForm = subformInfoArray(1) End If ' Update the form based on the subform information UpdateFormBasedOnSubformInfo End Sub دالة للتحكم فى اظهار واخفاء موضع صورة سهم تدل على النموذج الفرعى تبعا لزر الامر ' Sub to move the arrow indicator on the form Sub MoveArrow() ' Make the arrow visible and position it below the active control If Not Me.imgArrow.Visible Then Me.imgArrow.Visible = True Me.imgArrow.Top = Me.ActiveControl.Top ChangeCommandButtonColor Me End Sub دالة تحديث النموذج بناء على المعطيات السابقة من الدوال بمجرد النقر على زر الامر ' Sub to update the form based on the subform information Sub UpdateFormBasedOnSubformInfo() Select Case Nz(strFormName, "frmHomeMenu") Case Is = "frmHomeMenu" Me.lblTitle.Caption = strTitleForm subformControl.Visible = False ChangeCommandButtonColor Me, False Me.imgArrow.Visible = False Me.subformControl.SourceObject = "" Me.subformControl.Height = 0 Case Else Me.lblTitle.Caption = strTitleForm MoveArrow ChangeCommandButtonColor Me Me.subformControl.Height = BoxMain.Height Me.subformControl.SourceObject = strFormName subformControl.Visible = True End Select End Sub الاكواد لضبط وتحديد الحدث المراد تنفيذه تبعا لازرار الاوامر ' Function to convert ButtonAction to corresponding form description Function ButtonActionToString(btnAction As ButtonAction) As String Select Case btnAction Case ButtonAction.HomeMenu: ButtonActionToString = "HomeMenu" Case ButtonAction.ImportExcel: ButtonActionToString = "ImportExcel" Case ButtonAction.DailyEmployee: ButtonActionToString = "DailyEmployee" Case ButtonAction.QueryDailyBy: ButtonActionToString = "QueryDailyBy" Case ButtonAction.EmployeesData: ButtonActionToString = "EmployeesData" Case ButtonAction.DailyLogsType: ButtonActionToString = "DailyLogsType" Case ButtonAction.Department: ButtonActionToString = "Department" Case ButtonAction.Section: ButtonActionToString = "Section" End Select End Function الاكواد على ازرار الاوامر Private Sub ImageLogo_Click() HandleButtonClick HomeMenu End Sub Private Sub btnNavItem1_Click() HandleButtonClick ImportExcel End Sub Private Sub btnNavItem2_Click() HandleButtonClick DailyEmployee End Sub Private Sub btnNavItem3_Click() HandleButtonClick QueryDailyBy End Sub Private Sub btnNavItem4_Click() HandleButtonClick EmployeesData End Sub Private Sub btnNavItem5_Click() HandleButtonClick DailyLogsType End Sub Private Sub btnNavItem6_Click() HandleButtonClick Department End Sub Private Sub btnNavItem7_Click() HandleButtonClick Section End Sub واخيرا وحدة نمطية باسم basChangeButtonColor خاصة بتغير لون زر الامر الذى يتم الضغط عليه فى النموذج الرئيسى ' Enum for colors Enum ColorEnum WhiteColor = 16777215 ' White RedColor = 255 ' Red GreenColor = 32768 ' Green BlueColor = 16711680 ' Blue PurpleColor = 8388736 ' Purple GrayColor = 8421504 ' Gray OrangeColor = 16753920 ' Orange BrownColor = 10824234 ' Brown BlackColor = 0 ' Black CyanColor = 16776960 ' Cyan MagentaColor = 16711935 ' Magenta YellowColor = 65535 ' Yellow LightBlueColor = 173216230 ' Light Blue DarkGreenColor = 65280 ' Dark Green PinkColor = 16761035 ' Pink LavenderColor = 230230250 ' Lavender OliveColor = 32896 ' Olive AquaColor = 65535 ' Aqua TurquoiseColor = 4251856 ' Turquoise GoldColor = 16766720 ' Gold SilverColor = 12632256 ' Silver MaroonColor = 8388608 ' Maroon NavyColor = 128 ' Navy TealColor = 8421376 ' Teal CoralColor = 5275647 ' Coral SalmonColor = 16416882 ' Salmon IndigoColor = 4915330 ' Indigo PeachColor = 16775640 ' Peach SiennaColor = 10506797 ' Sienna SkyBlueColor = 8900331 ' Sky Blue End Enum ' Module-level variables Dim currentButtonBackColor As Long ' Variable to store the current button back color Dim currentButtonForeColor As Long ' Variable to store the current button fore color Dim selectedButton As CommandButton ' Variable to store the selected button ' Subroutine to set the button color Sub SetButtonColor(ByVal frm As Form, Optional btn As CommandButton = Nothing) ' Set new button colors Dim newButtonBackColor As Long Dim newButtonForeColor As Long newButtonBackColor = ColorEnum.GrayColor newButtonForeColor = ColorEnum.BlackColor If Not btn Is Nothing Then ' Store the current button's colors currentButtonBackColor = btn.BackColor currentButtonForeColor = btn.ForeColor ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = currentButtonBackColor selectedButton.ForeColor = currentButtonForeColor End If ' Set the new button as selected and highlight it Set selectedButton = btn btn.BackColor = newButtonBackColor btn.ForeColor = newButtonForeColor End If End Sub ' Subroutine to change the button color Sub ChangeCommandButtonColor(frm As Form, Optional changeColor As Boolean = True) On Error GoTo ErrorHandler Dim clickedButton As CommandButton Set clickedButton = frm.ActiveControl ' Store the default button colors before changing Dim currentButtonBackColor As Long Dim currentButtonForeColor As Long currentButtonBackColor = clickedButton.BackColor currentButtonForeColor = clickedButton.ForeColor ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = currentButtonBackColor selectedButton.ForeColor = currentButtonForeColor End If ' Set the new button as selected and highlight it Set selectedButton = clickedButton ' Apply the button color if changeColor is True If changeColor Then SetButtonColor frm, clickedButton End If Err.Clear ' Clear Err Exit Sub ' Exit to avoid handler. ErrorHandler: ' Error-handling routine. Select Case Err.Number ' Evaluate error number. Case Is = 5 Resume Next Exit Sub ' Exit to avoid handler. Case Else ' Handle other situations here... MsgBox "Error: " & Err.Number & vbCrLf & "Description: " & Err.Description Resume ' Resume execution at the same line End Select End Sub المميزات : 1- عند الابتعاد عن الشاشة والعودة مرة أخرى بمجرد النظر يمكنك معرفة الزر الاخير الذى تم الضغط عليه 2-سهولة تغيير العناوين التى تظهر على الشاشة الرئيسية تبعا لكل نموذج فرعى بكل سهولة بدون داعى للدخول الى عرض التصميم من الجدول اختبار تجربة يتبع ... واخيرا المرفق HRManagement V 1.0.2.zip

هذه الدوال كانت تعمل على النواة 32 بدون اى مشاكل ولكن لم تعمل مع النواة 64 تمت التعديلات اللازمة على الكود للعمل على النواتان 32,64 بيت تم التجربة الشخصية والتأكد من فاعلية هذه التعديلات على ويندوز 64 بيت اوفيس 64 بيت فضلا وليس امرا فى انتظار ارائكم والردود بعد التجربة على انوية مختلفة للتأكد من فاعلية التعديل Option Compare Database Option Explicit #If Win64 Then ' Declare functions for 64-bit Windows Private Declare PtrSafe Function NetRemoteTOD Lib "Netapi32.dll" ( _ bServer As Any, pBuffer As LongPtr) As Long Private Declare PtrSafe Function NetApiBufferFree Lib "Netapi32.dll" (ByVal lpBuffer As LongPtr) As Long #Else ' Declare functions for 32-bit Windows Private Declare Function NetRemoteTOD Lib "Netapi32.dll" ( _ bServer As Any, pBuffer As Long) As Long Private Declare Function NetApiBufferFree Lib "Netapi32.dll" (ByVal lpBuffer As Long) As Long #End If #If VBA7 Then ' Declare functions for VBA7 (Office 2010 and later) Private Declare PtrSafe Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr) #Else ' Declare functions for earlier versions of VBA Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) #End If ' Define custom data types for SYSTEMTIME, TIME_ZONE_INFORMATION, and TimeOfDayInfo Private Type 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 Private Type TIME_ZONE_INFORMATION Bias As Long StandardName(32) As Integer StandardDate As SYSTEMTIME StandardBias As Long DaylightName(32) As Integer DaylightDate As SYSTEMTIME DaylightBias As Long End Type Private Type TimeOoDayInfo tod_elapsedt As Long tod_msecs As Long tod_hours As Long tod_mins As Long tod_secs As Long tod_hunds As Long tod_timezone As Long tod_tinterval As Long tod_day As Long tod_month As Long tod_year As Long tod_weekday As Long End Type ' Constant for success code Private Const NERR_SUCCESS As Long = 0 ' Constant for default time indicating failure Private Const DEFAULT_TIME As Date = #12:00:00 AM# Public myIP As String ' Function to get Time Of Day from a remote server Private Function GetTOD(ByVal Server As String) As Date #If VBA7 Then Dim lngBufPtr As LongPtr #Else Dim lngBufPtr As Long #End If Dim bytServer() As Byte Dim todReturned As TimeOoDayInfo Dim success As Boolean On Error Resume Next ' Convert server string to null-terminated byte array bytServer = Trim$(Server) & vbNullChar ' Call NetRemoteTOD function and check for success success = NetRemoteTOD(bytServer(0), lngBufPtr) = NERR_SUCCESS On Error GoTo 0 If success Then ' Copy memory and free buffer CopyMemory todReturned, ByVal lngBufPtr, LenB(todReturned) NetApiBufferFree lngBufPtr ' Calculate date and time from TimeOoDayInfo structure With todReturned GetTOD = DateAdd("n", _ -.tod_timezone, _ DateSerial(.tod_year, .tod_month, .tod_day) _ + TimeSerial(.tod_hours, .tod_mins, .tod_secs)) End With Else ' Return default time in case of failure GetTOD = DEFAULT_TIME End If End Function ' Subroutine to get remote time and display a message Public Function GetRemoteTime(ByVal ServerIP As String) Dim d As Date ' Call GetTOD function with a sample IP address d = GetTOD(ServerIP) ' Check if the returned time is the default time indicating failure If d = DEFAULT_TIME Then ' Display an error message MsgBox "Failed to get remote time. Please check the IP address or ensure the server is reachable.", vbExclamation Else ' Print the remote time to the Debug window GetRemoteTime = d Debug.Print d End If End Function Sub Test_setIP() myIP = "192.168.0.133" Call GetRemoteTime(myIP) End Sub طبعا لابد من تعديل الـ Ip بجهاز اخر على الشبكة المحلية myIP = "192.168.0.133"

الان الجداول الاساسية المرفق بالجداول اللازمة HR Managment.zip

طيب فى الاستعلام مصدر التقرير حقل تاريخ البطاقة لو اسمه CardDate اضف حقل جديد فى الاستعلام بالشكل التالى Year(CardDate) ولعرض البطاقات الفعالة فقط فى المعيار لهذا الحقل ضع : >=Year(Date()) ولعرض البطاقات الغير فعالة فقط فى المعيار لهذا الحقل ضع : <Year(Date()) طيب انت لو استخدمت العلامات اكبر من واصغر من فقط سوف يتم التعامل مع التاريخ كاملا ولكن بما انك تريد التعامل مع السنوات لابد من ارجاع التاريخ اولا للعام للحقل وللمعيار

البيانات الرئيسية والتى نريد تحضيرها مرة واحدة فقط عند بدء التطيق لنتمكن من استخدامها فى زوايا التطبيق المختلفة على سبيل المثال وليس الحصر نريد اسم الشركة دائما فى كل التقارير مثلا عند تحقق شرط معين بيانات الاتصال بالمصمم لعمل ذلك نقوم ببناء جدول ليكون اسمه tblGlobalInformation بناء الجدول يعتمد على حقلين itemName , itemValue والان وحدة نمطية جديدة ليكون اسمها = basGlobalInformation فى الوحدة النمطية نقوم بعمل Enumeration هي كلاسات خاصة تستخدم لتعريف ثوابت محددة مسبقا وتستخدم لتخزين عناصر متتالية دفعة واحدة بعدها يمكنه إرجاع هذه العناصر واحدا تلو الآخر حسب الحاجة الاكواد داخل الوحدة النمطية basGlobalInformation Option Compare Database Option Explicit ' Enumeration defining global information indices Public Enum EnumInformation EnumStartIndex ' Enumeration values for global information start infSoftwarName infSoftwarVersion infDesignCompany infDesigerName infDesigerMail infDesigerPhone infCompanyName infCompanyGM EnumEndIndex = infCompanyGM ' Enumeration value for global information end End Enum ' Array to store global information values Public Ginf() As String ' Public variables to store individual global information values Public GetSoftwarName As String Public GetSoftwarVersion As String Public GetDesignCompany As String Public GetDesigerName As String Public GetDesigerMail As String Public GetDesigerPhone As String Public GetCompanyName As String Public GetCompanyGM As String ' The name of the table Global Information Public Const TableGlobalInformationName As String = "tblGlobalInformation" Function IsArrayInitialized(arr As Variant) As Boolean ' Check if the array is initialized (not empty or uninitialized) On Error Resume Next IsArrayInitialized = (UBound(arr) >= LBound(arr)) On Error GoTo 0 End Function Public Sub SetGlobalVariables() ' Procedure to set global variables based on database values On Error Resume Next ' Open a recordset based on the SQL query Dim db As DAO.Database Dim rs As DAO.Recordset Dim strSQL As String Set db = CurrentDb ' Check if the table exists in the database If Not IsTableExists(TableGlobalInformationName, db) Then Exit Sub ' Check if global information values are already populated If Not IsArrayInitialized(Ginf) Then ' Resize the global information values array based on the count of enumeration items ReDim Ginf(1 To EnumEndIndex - EnumStartIndex) As String ' Create a SQL query to retrieve all required items in one go strSQL = "SELECT itemName, itemValue FROM " & TableGlobalInformationName & " WHERE itemName " & _ "IN ('SoftwarName', 'SoftwarVersion', 'DesignCompany', 'DesigerName', " & _ "'DesigerMail', 'DesigerPhone', 'CompanyName', 'CompanyGM');" ' Open a recordset based on the SQL query Set rs = db.OpenRecordset(strSQL) ' Loop through the recordset and assign values to global information values array Do While Not rs.EOF Dim itemName As String itemName = rs.Fields("itemName").Value Dim itemIndex As Integer itemIndex = GetInfoIndex(itemName) If itemIndex <> -1 Then Ginf(itemIndex) = rs.Fields("itemValue").Value Else Debug.Print "ItemName: " & itemName & " not found in EnumInf." End If rs.MoveNext Loop ' Assign individual global information values to public variables GetSoftwarName = Ginf(EnumInformation.infSoftwarName) GetSoftwarVersion = Ginf(EnumInformation.infSoftwarVersion) GetDesignCompany = Ginf(EnumInformation.infDesignCompany) GetDesigerName = Ginf(EnumInformation.infDesigerName) GetDesigerMail = Ginf(EnumInformation.infDesigerMail) GetDesigerPhone = Ginf(EnumInformation.infDesigerPhone) GetCompanyName = Ginf(EnumInformation.infCompanyName) GetCompanyGM = Ginf(EnumInformation.infCompanyGM) ' Close the recordset rs.Close Set rs = Nothing End If ' Handle errors If Err.Number <> 0 Then ' Handle error If Err.Number = 94 Then Exit Sub ' Handle the error (display a message) Call ErrorLog(Err, Error$, "basEnumInformationrmation : SetGlobalVariables") Err.Clear End If On Error GoTo 0 End Sub Function GetInfoIndex(itemName As String) As Integer ' Helper function to get the index of an item in the EnumInformation enumeration Select Case itemName Case "SoftwarName" GetInfoIndex = EnumInformation.infSoftwarName Case "SoftwarVersion" GetInfoIndex = EnumInformation.infSoftwarVersion Case "DesignCompany" GetInfoIndex = EnumInformation.infDesignCompany Case "DesigerName" GetInfoIndex = EnumInformation.infDesigerName Case "DesigerMail" GetInfoIndex = EnumInformation.infDesigerMail Case "DesigerPhone" GetInfoIndex = EnumInformation.infDesigerPhone Case "CompanyName" GetInfoIndex = EnumInformation.infCompanyName Case "CompanyGM" GetInfoIndex = EnumInformation.infCompanyGM End Select End Function طيب بما اننا نتكلم عن اعدادات مهمة لابد من تحقيقها عند بدء التطبيق سوف نقوم بعمل وحدة نمطية باسم basInitialization ونضع بها الاكواد الاتية Rem Subroutine to initialize the application Sub InitializeApplication() Rem Initialize the error log table if it doesn't exist If Not IsErrorLogTableInitialized() Then CreateErrorLogTable Rem Call the function to set global variables. SetGlobalVariables End Sub ونقوم بعمل نموذج البدء ليكون اسمه frmInitialization فى هذا النموذج نستدعى الدالة السابقة فى حدث عند تحميل النموذج بالشكل التالى Private Sub Form_Load() On Error Resume Next Rem Set the initial time as the interval for the timer Rem Initialize the application when the startup form is loaded. InitializeApplication Rem Add calls to the initialized special functions through which you want the database to be booted Rem Or add specify the codes through which you would like to process the data later according to the requirements of your design Rem Set the current procedure name (you can adjust the procedure name as needed) If Err.Number <> 0 Then Rem Clear the error Err.Clear End If End Sub يتبع ... واخيرا المرفق HRManagement V 1.0.0.accdb

ولا انا انا جاوبت نظريا بناء على السؤال انا لا استطيع الان رفع او تنزيل اى مرفقات