Debug Ace

اذا : [تصحيح برمجي] تخرب الكود فيما يخص تحويل الدوال : 60 % يكون مخطئ وانا كنت رحيم انى قلت 60 مش أعلى من كده يمكن هذه تحتمل 50% مازلت عند رأيى ولا انصح بتجربته ولا بالاعتماد عليه الا للمحترفيين الذين يستطيعون تعديل وتصحيح الاخطاء التى سوف تنتج عنه لا يعتمد عليه نهائيا مضيعة للوقت والجهد

من المفترض انه يقوم بتحويل الكود إلى صيغة متوافقة مع النواتين 32 و 64 بت ليست كل الاكواد يتم تحويلها بشكل صحيح لا يعتمد عليه نهائيا ناهيكم عن أنه قام من تلقاء نفسه بتعديل الجزء الاخير من الكود الخاص بى من معالج الاخطاء من rs.Close الى : If rs.State = adStateOpen Then rs.Close هو لا يصحح اخطاء برمجية بل هو يقوم باضافة أخطـــ(bugs)ــــاء الى الكود يضيع الوقت والجهد

(OLE + AppendChunk) هذه الفكرة هى كديناصور قوي… لكنه منقرض تقنيا لهذه النقاط : محبوس داخل Access لا يفهمه SQL Server جيدا يصعب نقله أو تحديثه الديناصورات جميلة لكن لا تبني بها ناطحات سحاب ومن اجل ذلك ان ستخدام : Attachment Field هو الافضل ان استدعت الحاجة الى ذلك وهو التطور الطبيعي وملاحظة هامة جدا جدا جدا : اسلوب : (OLE + AppendChunk) يزيد حجم ومساحة القاعدة الى الضعف تقريبا مقارنة بـ : Attachment Field بعنى الملف المراد حملة داخل القاعدة من خلال : (OLE + AppendChunk) اذا كانت مساحة الملف مثلا 12 ميجا لاحظ انه بعد حملة تجد مساحة القاعدة الكلية = 24 ميجا تقريبا بينما تظل المساحة كما هى تقريبا فى حالة استخدام : Attachment Field طبعا اصدار الاوفيس ان كان اقدم من 2007 اى انه mdb للاسف لن تصلح معه الى هذه الفكرة بينما الاصدارات الاحدث accdb اى الاحدث من 2007 تصلح معه الطريقتان ولكن الافضل : Attachment Field

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

رؤية اية معذرة انا مش فاهم حاجة هل فى اى مشكلة

السلام عليكم ورحمة الله تعالى اولا كل الشكر وكل التقدير والاحترام لكل رواد المنتدى المحترمين الافكار جميعها ولا اروع والان حان وقت مشاركتى فكرتى تعتمد على عمل التالى كلاس موديول عارف ان فى اجابات احتوت على افكار بسيطة جدا جدا جدا وفعالةوفكرتى هى كالاتى امكانية عمل نماذج تقييم متعددة ليحتوى احد النماذج على تقييم لا يتعدى الثلاث نجوم ونموذج اخر مثلا 5 نجوم وممكن نموذج كمان يحتوى على 10 نجوم فكرتى كود مركزى واحد يعمل على الجميع امكانية اعطاء نفس النجمة او ازالتها اما من نفس النجمة او بالنجمة التى تسبقها نبدأ شرح المنهج المتبع والفكرة والاكواد انشاء وحدة نمطية عامة من النوع كلاسس باسم: clsStarRating الكود سوف يكون: Option Compare Database Option Explicit ' ========================================== ' الثوابت الافتراضيةالخاصة ' ========================================== Private Const DEFAULT_SOLID_STAR As Long = &H2605 ' رمز النجمة المصمتة Private Const DEFAULT_HOLLOW_STAR As Long = &H2606 ' رمز النجمة المفرغة Private Const DEFAULT_TOTAL_STARS As Integer = 6 Private Const MAX_STARS As Integer = 20 ' ========================================== ' المتغيرات الخاصة Private mStarCount As Integer Private mRating As Integer Private mSolidSymbol As Long Private mHollowSymbol As Long Private mLastForm As Form Private mLastRatingField As String Private mStarsExpression As String ' ========================================== ' التهيئة ' ========================================== Public Sub Initialize(Optional ByVal starCount As Integer = DEFAULT_TOTAL_STARS, _ Optional ByVal SolidSymbol As Long = DEFAULT_SOLID_STAR, _ Optional ByVal HollowSymbol As Long = DEFAULT_HOLLOW_STAR) mStarCount = IIf(starCount >= 1 And starCount <= MAX_STARS, starCount, DEFAULT_TOTAL_STARS) mSolidSymbol = SolidSymbol mHollowSymbol = HollowSymbol mRating = 0 ClearCache End Sub ' ========================================== ' تبديل حالة التقييم ' ========================================== Public Sub StarClick(ByVal index As Integer) If index < 1 Or index > mStarCount Then Exit Sub mRating = IIf(index = mRating, IIf(index = 1, 0, index - 1), index) End Sub ' ========================================== ' تحميل/حفظ >-->> فائق الكفاءة ' ========================================== Public Sub LoadFromForm(Form As Form, ratingControl As String, Optional ByVal showMessage As Boolean = False) On Error GoTo ErrHandler mRating = Nz(Form.Controls(ratingControl).value, 0) CleanExit: Exit Sub ErrHandler: Debug.Print "LoadFromForm Error #" & Err.Number & ": " & Err.Description If showMessage Then MsgBox Err.Description, vbCritical Resume CleanExit End Sub Public Sub SaveToForm(Form As Form, ratingControl As String, Optional ByVal showMessage As Boolean = False) On Error GoTo ErrHandler If Form.NewRecord Then Exit Sub Form.Controls(ratingControl).value = mRating If Form.Dirty Then Form.Dirty = False CleanExit: Exit Sub ErrHandler: Debug.Print "SaveToForm Error #" & Err.Number & ": " & Err.Description If showMessage Then MsgBox Err.Description, vbCritical Resume CleanExit End Sub ' ========================================== ' محرك مركزى لتحديث عرض التقييم فى النموذج ' ========================================== Public Sub UpdateStarsForForm(FormObj As Form, ratingFieldName As String, _ Optional starPrefix As String = "txtStar", _ Optional textBoxName As String = "txtRatingText") On Error GoTo ErrHandler Static lastForm As Form, lastField As String If Not lastForm Is Nothing Then If lastForm Is FormObj And lastField = ratingFieldName Then Exit Sub End If Dim i As Integer, textExpr As String For i = 1 To mStarCount With FormObj.Controls(starPrefix & i) .ControlSource = "=Switch([" & ratingFieldName & "]>=" & i & _ ",ChrW(" & mSolidSymbol & "),True,ChrW(" & mHollowSymbol & "))" End With Next i ' نص التقييم (مرة واحدة) If Len(textBoxName) > 0 Then textExpr = "=Switch([" & ratingFieldName & "]=0,'بدون تقييم'," & _ "[" & ratingFieldName & "]=1,'نجمة'," & _ "[" & ratingFieldName & "]=2,'نجمتان'," & _ "True,[" & ratingFieldName & "] & ' نجوم')" FormObj.Controls(textBoxName).ControlSource = textExpr End If ' تحديث ذاكرة الكاش Set lastForm = FormObj lastField = ratingFieldName CleanExit: Exit Sub ErrHandler: Debug.Print "UpdateStars Error: " & Err.Description Resume CleanExit End Sub ' ========================================== ' تنظيف ذاكرة الكاش ' ========================================== Private Sub ClearCache() Set mLastForm = Nothing mLastRatingField = "" End Sub ---- اولا نبدأ بـــ :دليل التشغيل السريع لنظام تقييم النجوم أعداد اى نموذج مربعات النص المطلوبة: txtRatingValue ← مرتبط بحقل فى الجدول نوع الحقل رقمى ليسجل قيمة التقييم مثل ← (التقييم 0-10) txtRatingText ← (غير منضم ولا يرتبط بأى حقول فى الجدول) يعرض نص مثل ← "3 نجوم" مربعات نص txtStarX تبدأ من txtStar1 الى عدد النجوم التى تريد وضعها فى النموذج مثلا ← txtStar10 (غير منضمة جميعها ولا ترتبط بأى حقول فى الجدول) ← عرض نجوم التقييم ⭐ الأزرار btnStarX خصائصها شفافة وتكون بنفس عدد مربعات النص السابقة وتكون مواضعها فوق مربعات النص فى المقدمة كود النموذج Option Compare Database Option Explicit ' ========================================== ' إعدادات النموذج الثابتة (Configuration) ' ========================================== ' عدد النجوم Private Const cintTotalStars As Integer = 10 ' حقل التقييم Private Const cstrRatingControl As String = "txtRatingValue" ' بادئة أزرار النجوم Private Const cstrButtonPrefix As String = "btnStar" ' بادئة مربعات نص النجوم Private Const cstrStarPrefix As String = "txtStar" ' نص التقييم Private Const cstrTextControl As String = "txtRatingText" Private StarEngine As clsStarRating ' ========================================== ' فتح النموذج - التهيئة الكاملة ' ========================================== Private Sub Form_Open(Cancel As Integer) On Error GoTo ErrHandler Dim ctl As Control ' إنشاء محرك النجوم Set StarEngine = New clsStarRating StarEngine.Initialize cintTotalStars ' تحميل التقييم الحالي If Not Me.NewRecord Then StarEngine.LoadFromForm Me, cstrRatingControl End If ' ربط أزرار النجوم ديناميكيا For Each ctl In Me.Controls If ctl.ControlType = acCommandButton And ctl.Name Like cstrButtonPrefix & "*" Then ctl.OnClick = "=HandleStarClick(""" & ctl.Name & """)" End If Next ctl ' تحديث العرض StarEngine.UpdateStarsForForm Me, cstrRatingControl, cstrStarPrefix, cstrTextControl CleanExit: Exit Sub ErrHandler: Debug.Print "Form_Open Error #" & Err.Number & ": " & Err.Description MsgBox "خطأ في التهيئة: " & Err.Description, vbCritical, "Star Rating" Resume CleanExit End Sub ' ========================================== ' معالج ربط أحداث أزرار تقييم النجوم الديناميكي (مركزي) ' ========================================== Public Function HandleStarClick(ByVal strButtonName As String) As Variant On Error GoTo ErrHandler Dim intStarIndex As Integer intStarIndex = Val(Mid(strButtonName, Len(cstrButtonPrefix) + 1)) ' التحقق من صحة النجمة If intStarIndex < 1 Or intStarIndex > cintTotalStars Then HandleStarClick = False Exit Function End If ' تسلسل العمليات: Load >> Click >> Save >> Refresh StarEngine.LoadFromForm Me, cstrRatingControl StarEngine.StarClick intStarIndex StarEngine.SaveToForm Me, cstrRatingControl, False ' False = no message (بدون رسائل) HandleStarClick = True CleanExit: Exit Function ErrHandler: Debug.Print "HandleStarClick Error [" & strButtonName & "] #" & Err.Number & ": " & Err.Description HandleStarClick = False Resume CleanExit End Function ' ========================================== ' إغلاق آمن ' ========================================== Private Sub Form_Unload(Cancel As Integer) Set StarEngine = Nothing End Sub وطبعا يتم تعديل الاعدادت فى اعلى كود النموذج حسب المسميات ان اردت تغييرها فى النموذج بما يناسبك انت ' عدد النجوم Private Const cintTotalStars As Integer = 10 ' حقل التقييم Private Const cstrRatingControl As String = "txtRatingValue" ' بادئة أزرار النجوم Private Const cstrButtonPrefix As String = "btnStar" ' بادئة مربعات نص النجوم Private Const cstrStarPrefix As String = "txtStar" ' نص التقييم Private Const cstrTextControl As String = "txtRatingText" وبكده يكون معانا فكرة وتنفيذ لكود مرن لا يتطلب اى تدخل منك فى المستقبل ان اردت زيادة اعداد عناصر التقييم الا فقط باتباع نهج المواضع والمسميات لا تعديل فى الكود ولن تحتاج الى اضافة اى اكواد فى النموذج امكانية عمل اكثر من نموذج للتقييم فى نفس قاعدة البيانات على ان يكون لكل نموذج عدد تقييمات خاصة به وتختلف عن غيره وأخيرا اليكم مرفقا للتجربة والتقييم للفكرة وألية العمل الاستاذ الفاضل @ابوخليل اترك لكم حرية اختيار افضل اجابة لتكون مرجعا لرواد المنتدى ولكم خالص الشكر والتقدير لتقييم النجوم ( V1.2).accdb.zip

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

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

حلوة فكرتك يا فنان عجبتنى بس لو عاوزين ننفذها بنفس شكل الصورة اللى انا ارفقتها ممكن ؟

نعم

هل يمكن تصميم نظام للتقيم بالنجوم مثل -المنتجات والخدمات - أداء الموظفين - المحتوى والمقالات صورة للتوضيح : هل يمكن أن نرى ابداع رواد المنتدى المحترمين فى الافكار و التنفيذ ....

لو بحثت على الانترنت سوف تجد ضالتك وده احد المواقع على سيبل المثال https://www.vecteezy.com/free-vector/incoming-mail

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

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

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

ممتاز جدا جدا وانا قمت بتجربة كود جلب الخطوط العربية فقط من النظام وسوف ادمج بينه وبين طريقتى لتمكين المطور او المستخدم من تحديد خطوط معينه ان اراد ذلك فى المستقبل وهذا الكود المنقح Option Compare Database Option Explicit '=== تعريف LOGFONT === Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName(0 To 31) As Byte End Type Private Const ARABIC_CHARSET As Byte = 178 Private Const DEFAULT_CHARSET As Byte = 1 '=== الـ API Declarations === #If VBA7 Then Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" _ (ByVal hdc As LongPtr, lpLogFont As LOGFONT, ByVal lpEnumFontProc As LongPtr, _ ByVal lParam As LongPtr, ByVal dwFlags As Long) As Long #Else Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" _ (ByVal hdc As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, _ ByVal lParam As Long, ByVal dwFlags As Long) As Long #End If Private m_FontList As Collection '=== الدالة الرئيسية === Public Sub LoadArabicFonts(cbo As Control, Optional IncludeNonArabic As Boolean = False) On Error GoTo ErrorHandler ' التحقق من صحة الـ Control If cbo Is Nothing Then Err.Raise 91, , "Control غير صالح" ' تهيئة القائمة بأمان SafeClearCombo cbo cbo.RowSourceType = "Value List" ' تحميل الخطوط Set m_FontList = New Collection If LoadSystemArabicFonts(IncludeNonArabic) Then PopulateComboBox cbo Else SafeAddItem cbo, "خطوط غير متوفرة" End If Exit Sub ErrorHandler: SafeClearCombo cbo SafeAddItem cbo, "خطأ في تحميل الخطوط" Debug.Print "LoadArabicFonts Error: " & Err.Number & " - " & Err.Description End Sub '=== وظائف مساعدة آمنة === Private Sub SafeClearCombo(cbo As Control) On Error Resume Next cbo.Clear On Error GoTo 0 End Sub Private Sub SafeAddItem(cbo As Control, itemText As String) On Error Resume Next cbo.AddItem itemText On Error GoTo 0 End Sub '=== تحميل الخطوط من النظام === Private Function LoadSystemArabicFonts(IncludeNonArabic As Boolean) As Boolean Dim hdc As LongPtr Dim lf As LOGFONT ' إعداد LOGFONT للخطوط العربية lf.lfCharSet = IIf(IncludeNonArabic, DEFAULT_CHARSET, ARABIC_CHARSET) ' الحصول على Device Context #If VBA7 Then hdc = GetDC(0) #Else hdc = GetDC(0&) #End If If hdc = 0 Then Exit Function On Error GoTo Cleanup EnumFontFamiliesEx hdc, lf, AddressOf EnumFontProc, 0, 0 Cleanup: LoadSystemArabicFonts = (m_FontList.Count > 0) #If VBA7 Then ReleaseDC 0, hdc #Else ReleaseDC 0&, hdc #End If On Error GoTo 0 End Function '=== Callback للخطوط === #If VBA7 Then Private Function EnumFontProc(lpelf As LOGFONT, ByVal lpntm As LongPtr, _ ByVal FontType As Long, ByVal lParam As LongPtr) As Long #Else Private Function EnumFontProc(lpelf As LOGFONT, ByVal lpntm As Long, _ ByVal FontType As Long, ByVal lParam As Long) As Long #End If On Error Resume Next Dim fName As String fName = StrConv(lpelf.lfFaceName, vbUnicode) fName = Left$(fName, InStr(fName, ChrW(0)) - 1) fName = Trim$(fName) ' فلتر TrueType فقط + تجنب التكرار If Len(fName) > 2 And (FontType And 4) = 4 And Not FontExists(fName) Then m_FontList.Add fName, fName ' Debug.Print "Font added: " & fName ' للاختبار End If EnumFontProc = 1 End Function '=== فحص وجود الخط === Private Function FontExists(fontName As String) As Boolean Dim f As Variant On Error Resume Next Set f = m_FontList(fontName) FontExists = (Err.Number = 0) On Error GoTo 0 End Function '=== ملء القائمة مع الترتيب === Private Sub PopulateComboBox(cbo As Control) Dim arr() As String Dim i As Long If m_FontList.Count = 0 Then Exit Sub ' تحويل Collection إلى Array ReDim arr(1 To m_FontList.Count) For i = 1 To m_FontList.Count arr(i) = m_FontList(i) Next i ' ترتيب سريع QuickSort arr, LBound(arr), UBound(arr) ' إضافة للـ ComboBox For i = LBound(arr) To UBound(arr) cbo.AddItem arr(i) Next i End Sub '=== Sort === Private Sub QuickSort(arr() As String, ByVal low As Long, ByVal high As Long) Dim pivot As String, i As Long, j As Long, temp As String If low < high Then pivot = arr((low + high) \ 2) i = low: j = high Do While StrComp(arr(i), pivot, vbTextCompare) < 0: i = i + 1: Wend While StrComp(arr(j), pivot, vbTextCompare) > 0: j = j - 1: Wend If i <= j Then temp = arr(i): arr(i) = arr(j): arr(j) = temp i = i + 1: j = j - 1 End If Loop While i <= j If low < j Then QuickSort arr, low, j If i < high Then QuickSort arr, i, high End If End Sub '=== وظيفة اختبار === Public Function GetArabicFontsCount() As Long Set m_FontList = New Collection LoadSystemArabicFonts False GetArabicFontsCount = m_FontList.Count End Function

وبذلك التعديل يصبح الكود فى النهاية بهذا الشكل '=== ÇáËæÇÈÊ ááæÑÏíÉ ÇáãÓÇÆíÉ === Private Const SHIFT_START_HOUR As Integer = 17 ' 5 ãÓÇÁ Private Const SHIFT_END_HOUR As Integer = 1 ' 1 ÕÈÇÍÇ Private Const DEFAULT_WORK_HOURS As Long = 8 Private Const DEFAULT_FREE_IN_MINS As Long = 30 Private Const DEFAULT_FREE_OUT_MINS As Long = 30 '=== 1. ÝÍÕ ãÇ ÅÐÇ ßÇä ÇáæÞÊ ÇáãÍÏÏ Öãä æÑÏíÉ ãÓÇÆíÉ === Public Function IsEveningShiftNow(Optional ByVal checkTime As Date = 0) As Boolean If checkTime = 0 Then checkTime = Time() IsEveningShiftNow = (checkTime >= TimeSerial(SHIFT_START_HOUR, 0, 0)) Or (checkTime < TimeSerial(SHIFT_END_HOUR, 0, 0)) End Function '=== 2. ÊÇÑíÎ ÇáæÑÏíÉ ÇáÍÇáíÉ === Public Function CurrentShiftDate(Optional ByVal currentTime As Date = 0) As Date If currentTime = 0 Then currentTime = Time() If IsEveningShiftNow(currentTime) Then If currentTime >= TimeSerial(SHIFT_START_HOUR, 0, 0) Then CurrentShiftDate = Date Else CurrentShiftDate = Date - 1 End If Else CurrentShiftDate = Date End If End Function '=== 3. ÞÑÇÁÉ ÅÚÏÇÏÇÊ ÇáæÑÏíÉ ãÑÉ æÇÍÏÉ === Private Function GetShiftSettings() As Variant Static cachedSettings As Variant Static lastCacheTime As Date If DateDiff("n", lastCacheTime, Now()) > 5 Then Dim rst As DAO.Recordset Set rst = CurrentDb.OpenRecordset("SELECT fatrah2_In, hours_Work2, free2_in, free2_out FROM tblTimeCtrl WHERE 1=1") If Not rst.EOF Then cachedSettings = Array( _ Nz(rst!fatrah2_In, "17:00:00"), _ Nz(rst!hours_Work2, DEFAULT_WORK_HOURS), _ Nz(rst!free2_in, DEFAULT_FREE_IN_MINS), _ Nz(rst!free2_out, DEFAULT_FREE_OUT_MINS) _ ) Else cachedSettings = Array("17:00:00", DEFAULT_WORK_HOURS, DEFAULT_FREE_IN_MINS, DEFAULT_FREE_OUT_MINS) End If rst.Close: Set rst = Nothing lastCacheTime = Now() End If GetShiftSettings = cachedSettings End Function '=== 4. æÞÊ ÈÏÇíÉ ÇáÊÓÌíá ÇáãÓãæÍ (ÞÈá ÇáÏÎæá ÇáÑÓãí) === Public Function funFirstTimeB_In(Optional ByVal refTime As Date = 0) As Date Dim settings As Variant: settings = GetShiftSettings() Dim officialIn As Date: officialIn = TimeValue(settings(0)) Dim freeMins As Long: freeMins = CLng(settings(2)) If refTime = 0 Then refTime = Time() Dim shiftDate As Date: shiftDate = CurrentShiftDate(refTime) funFirstTimeB_In = DateAdd("n", -freeMins, shiftDate + officialIn) End Function '=== 5. æÞÊ äåÇíÉ ÇáÊÓÌíá ÇáãÓãæÍ (ÈÚÏ ÇáÇäÕÑÇÝ ÇáÑÓãí) === Public Function funLastTimeB_Out(Optional ByVal refTime As Date = 0) As Date Dim settings As Variant: settings = GetShiftSettings() Dim officialIn As Date: officialIn = TimeValue(settings(0)) Dim workHours As Long: workHours = CLng(settings(1)) Dim extraMins As Long: extraMins = CLng(settings(3)) If refTime = 0 Then refTime = Time() Dim shiftDate As Date: shiftDate = CurrentShiftDate(refTime) funLastTimeB_Out = DateAdd("n", (workHours * 60) + extraMins, shiftDate + officialIn) End Function '=== 6. æÙÇÆÝ ÅÖÇÝíÉ ááÊÍÞÞ æÇáÇÎÊÈÇÑ ãÚ ãÚÇãá æÞÊ === Public Function GetCurrentShiftInfo(Optional ByVal refTime As Date = 0) As String Dim shiftDate As Date: shiftDate = CurrentShiftDate(refTime) GetCurrentShiftInfo = "ÇáæÑÏíÉ: " & Format(shiftDate, "yyyy-mm-dd") & " | " & _ "ÇáÏÎæá ÇáãÓãæÍ: " & Format(funFirstTimeB_In(refTime), "hh:nn") & " | " & _ "ÇáÎÑæÌ ÇáãÓãæÍ: " & Format(funLastTimeB_Out(refTime), "hh:nn") End Function '=== 7. ÇÎÊÈÇÑ ÇáãäØÞ === Public Function TestShiftLogic(Optional ByVal testTime As Date = 0) As String If testTime = 0 Then testTime = Now() TestShiftLogic = "ÇáæÞÊ: " & Format(testTime, "hh:nn:ss") & " ? " & GetCurrentShiftInfo(testTime) End Function Sub TestDebugPrint() Debug.Print TestShiftLogic() Debug.Print TestShiftLogic(#11:30:00 PM#) Debug.Print TestShiftLogic(#12:30:00 AM#) End Sub

وجهة نظرك منطقية وتحترم ينفع معاك الحل ده ؟ Public Function IsEveningShiftNow(Optional ByVal checkTime As Date = 0) As Boolean If checkTime = 0 Then checkTime = Time() IsEveningShiftNow = (checkTime >= TimeSerial(17, 0, 0)) Or (checkTime < TimeSerial(1, 0, 0)) End Function Public Function CurrentShiftDate(Optional ByVal currentTime As Date = 0) As Date If currentTime = 0 Then currentTime = Time() If IsEveningShiftNow(currentTime) Then If currentTime >= TimeSerial(17, 0, 0) Then CurrentShiftDate = Date Else CurrentShiftDate = Date - 1 End If Else CurrentShiftDate = Date End If End Function

الدالة لا تغير وقت النظام الحقيقي في الكمبيوتر الدالة محاكاة اختبار لمنطق الورديات بتغيير الوقت الحالي بشكل مؤقت لاختبار سلوك النظام في أوقات مختلفة دون انتظار مرور الوقت الحقيقي Public Function TestShiftLogic(Optional testTime As Date = 0) As String If testTime = 0 Then testTime = Now() ' 1. استخدم الوقت الحالي لو مفيش وقت محدد Dim originalTime As Date: originalTime = Time() ' 2. احفظ الوقت الأصلي Time = testTime ' 3. غير الوقت الحالي بشكل مؤقت ← **السر هنا** TestShiftLogic = "الوقت: " & Format(testTime, "hh:nn:ss") & " → " & GetCurrentShiftInfo() ' 4. نفذ الاختبار واحصل على النتيجة Time = originalTime ' 5. ارجع الوقت الأصلي ← **الأمان** End Function صارت الامور اوضح معك بهذا الشرح

اجابتى كانت من واقع خبرتى المتواضعه وفوق كل ذى علم عليم . شكرا ليك على هذه المعلومة سوف اقوم بالتجربة

طيب وانا كتبت الفكرة الثانية ليه تفتكر من فراغ يعنى ؟؟؟

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

طيب دى الفكرة الاولى '=== 1. فحص الوردية المسائية === Public Function IsEveningShiftNow() As Boolean Dim t As Date: t = Time() IsEveningShiftNow = (t >= #12:01:00 PM# And t < #12:00:00 AM#) End Function '=== 2. تاريخ الوردية الحالية === Public Function CurrentShiftDate() As Date CurrentShiftDate = IIf(IsEveningShiftNow(), Date, Date - 1) End Function '=== 3. وقت بداية التسجيل المسموح (قبل الدخول الرسمي) === Public Function funFirstTimeB_In() As Date Dim officialIn As String, freeMins As Long officialIn = Nz(DLookup("fatrah2_In", "tblTimeCtrl"), "17:00:00") freeMins = Nz(DLookup("free2_in", "tblTimeCtrl"), 30) funFirstTimeB_In = DateAdd("n", -freeMins, CurrentShiftDate + TimeValue(officialIn)) End Function '=== 4. وقت نهاية التسجيل المسموح (بعد الانصراف الرسمي) === Public Function funLastTimeB_Out() As Date Dim officialIn As String Dim workHours As Long, extraMins As Long officialIn = Nz(DLookup("fatrah2_In", "tblTimeCtrl"), "17:00:00") workHours = Nz(DLookup("hours_Work2", "tblTimeCtrl"), 8) extraMins = Nz(DLookup("free2_out", "tblTimeCtrl"), 30) funLastTimeB_Out = DateAdd("n", (workHours * 60) + extraMins, _ CurrentShiftDate + TimeValue(officialIn)) End Function ودى فكرة تانية '=============================================================================== ' نظام تحديد ورديات الدوام المسائية مع أوقات التسجيل المسموح بها ' وردية مسائية: 17:00 → 01:00 (تمتد بعد منتصف الليل) '=============================================================================== '=== الثوابت للوردية المسائية === Private Const SHIFT_START_HOUR As Integer = 17 ' 5 مساءً Private Const SHIFT_END_HOUR As Integer = 1 ' 1 صباحًا Private Const DEFAULT_WORK_HOURS As Long = 8 Private Const DEFAULT_FREE_IN_MINS As Long = 30 Private Const DEFAULT_FREE_OUT_MINS As Long = 30 '=== 1. فحص ما إذا كان الوقت الحالي ضمن وردية مسائية === Public Function IsEveningShiftNow() As Boolean Dim t As Date: t = Time() IsEveningShiftNow = (t >= TimeSerial(SHIFT_START_HOUR, 0, 0)) Or (t < TimeSerial(SHIFT_END_HOUR, 0, 0)) End Function '=== 2. تاريخ الوردية الحالية (الأصح للورديات المتداخلة) === Public Function CurrentShiftDate() As Date If IsEveningShiftNow() Then ' إذا كان بعد 17:00 اليوم أو قبل 01:00 اليوم التالي If Time() >= TimeSerial(SHIFT_START_HOUR, 0, 0) Then CurrentShiftDate = Date Else CurrentShiftDate = Date - 1 End If Else CurrentShiftDate = Date End If End Function '=== 3. قراءة إعدادات الوردية مرة واحدة (تحسين الأداء) === Private Function GetShiftSettings() As Variant Static cachedSettings As Variant Static lastCacheTime As Date ' تجديد الكاش كل 5 دقائق If DateDiff("n", lastCacheTime, Now()) > 5 Then Dim rst As DAO.Recordset Set rst = CurrentDb.OpenRecordset("SELECT fatrah2_In, hours_Work2, free2_in, free2_out FROM tblTimeCtrl WHERE 1=1") If Not rst.EOF Then cachedSettings = Array( _ Nz(rst!fatrah2_In, "17:00:00"), _ Nz(rst!hours_Work2, DEFAULT_WORK_HOURS), _ Nz(rst!free2_in, DEFAULT_FREE_IN_MINS), _ Nz(rst!free2_out, DEFAULT_FREE_OUT_MINS) _ ) Else cachedSettings = Array("17:00:00", DEFAULT_WORK_HOURS, DEFAULT_FREE_IN_MINS, DEFAULT_FREE_OUT_MINS) End If rst.Close: Set rst = Nothing lastCacheTime = Now() End If GetShiftSettings = cachedSettings End Function '=== 4. وقت بداية التسجيل المسموح (قبل الدخول الرسمي) === Public Function funFirstTimeB_In() As Date Dim settings As Variant: settings = GetShiftSettings() Dim officialIn As Date: officialIn = TimeValue(settings(0)) Dim freeMins As Long: freeMins = CLng(settings(2)) funFirstTimeB_In = DateAdd("n", -freeMins, CurrentShiftDate + officialIn) End Function '=== 5. وقت نهاية التسجيل المسموح (بعد الانصراف الرسمي) === Public Function funLastTimeB_Out() As Date Dim settings As Variant: settings = GetShiftSettings() Dim officialIn As Date: officialIn = TimeValue(settings(0)) Dim workHours As Long: workHours = CLng(settings(1)) Dim extraMins As Long: extraMins = CLng(settings(3)) funLastTimeB_Out = DateAdd("n", (workHours * 60) + extraMins, CurrentShiftDate + officialIn) End Function '=== 6. وظائف إضافية للتحقق والاختبار === Public Function GetCurrentShiftInfo() As String Dim shiftDate As Date: shiftDate = CurrentShiftDate() GetCurrentShiftInfo = "الوردية: " & Format(shiftDate, "yyyy-mm-dd") & " | " & _ "الدخول المسموح: " & Format(funFirstTimeB_In(), "hh:nn") & " | " & _ "الخروج المسموح: " & Format(funLastTimeB_Out(), "hh:nn") End Function Public Function TestShiftLogic(Optional testTime As Date = 0) As String If testTime = 0 Then testTime = Now() Dim originalTime As Date: originalTime = Time() Time = testTime ' اختبار مؤقت TestShiftLogic = "الوقت: " & Format(testTime, "hh:nn:ss") & " → " & GetCurrentShiftInfo() Time = originalTime ' إعادة الوقت الأصلي End Function بصراحة لم اقم باى تجارب خى مجرد تعديلات للاكواد بشكل نظرى تماما وفق فهمى

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

االرجاء الانتظار الى الانتهاء من باقى التعديلات CertificateCustomization.zip