كل الانشطه

جرب هذا التعديل أخي الكريم :- Private Sub Workbook_Open() Dim filePath As String ' المسار الكامل للملف filePath = "C:\Program Files\new\officeteam.txt" ' تحقق من وجود الملف If Dir(filePath) = "" Then MsgBox "ليس لديك الاذن في الاستخدام, يرجى التواصل مع مالك النظام . تنبيه.", vbCritical ThisWorkbook.Close SaveChanges:=False End If End Sub المشكلة أن الكود الذي كتبته يحتوي على خطأ في طريقة تحديد المسار ، حيث إنك قمت بدمج filePath مع requiredFile مرتين .

أخي الكريم ، هل الملف يعمل معك بشكل سليم أولاً ؟؟؟ فعادة تطبيق واتس اب يغير في طريقة الربط والارسال في تحديثاته على حد علمي . فهل قمت بتجربة الفكرة أولاً ؟؟؟؟ طبعاً الخلل ليس في الفكرة وطريقة التنفيذ ، وإنما كما أخبرتك هي في تحديثات شركة Meta ( و Whatsapp أحد منتجاتها حالياً )

تفضل :- القاعدة 2.zip

أسعدك الله وبارك الله بك ، وهنأك بعلمه الذي علمك إياه .. وأتمنى لك المزيد من التوفيق والتألق بأعمالك المميزة التي نريد رؤيتها قريباً شكراً لك

السلام عليكم ورحمة الله وبركاته المطلوب حسب ما فهمت هو : إضافةً إلي ما يفعلة إستعلام التحديث الحالي انت تريد تحديث العمود G N بأخر رقم موجود في جدول الجرد تفضل أخي الكريم جرب هذا الكود Public Function arTableName() As String arTableName = ChrW(1580) & ChrW(1583) & ChrW(1608) & ChrW(1604) & ChrW(32) & _ ChrW(1578) & ChrW(1587) & ChrW(1580) & ChrW(1610) & ChrW(1604) & ChrW(32) & _ ChrW(1575) & ChrW(1604) & ChrW(1603) & ChrW(1578) & ChrW(1576) End Function Private Sub أمر8_Click() Dim arTblName As String Dim maxGN As Long Dim arMsgPrompt As String Dim arMsgTitle As String Dim msgResponse As VbMsgBoxResult On Error GoTo ErrorHandler arTblName = arTableName maxGN = DMax("[No_Gard]", "[T_Gard]") arMsgTitle = "تأكيد تنفيذ الأمر" arMsgPrompt = "أنت على وشك تحديث حالة جميع الكتب باليومية" arMsgPrompt = arMsgPrompt & vbCrLf & "من كتب موجودة إلى كتب فاقد" arMsgPrompt = arMsgPrompt & vbCrLf & "لتأكيد الأمر أضغط موافق ، ولإلغائه أضغط إلغاء" msgResponse = MsgBox(arMsgPrompt, vbQuestion + vbOKCancel + vbMsgBoxRight, arMsgTitle) 'تعني تحويل حالة جميع الكتب في البرنامج من الرقم العام "واحد" ((والذي سيظهر بمجرد فتح النموذج) ) الى آخر رقم عام مسجل باليومية والمذكور داخل "نص2" سواء كان هذا الكتاب له عنوان أو بدون عنوان من الحالة موجود الى الحالة فاقد 'strSQL = "UPDATE [جدول تسجيل الكتب] SET [جدول تسجيل الكتب].CaseBook = ""فاقد"" " & vbCrLf & _ ' "WHERE ((([جدول تسجيل الكتب].CaseBook)=""موجود"") AND (Not ([جدول تسجيل الكتب].title) Is Null) AND (([جدول تسجيل الكتب].searinumber) Between [forms]![F_GardBooks]![text] And [forms]![F_GardBooks]![text2])) OR ((([جدول تسجيل الكتب].CaseBook)=""موجود"") AND (([جدول تسجيل الكتب].title) Is Null) AND (([جدول تسجيل الكتب].searinumber) Between [forms]![F_GardBooks]![text] And [forms]![F_GardBooks]![text2]));" strSQL = "UPDATE [" & arTblName & "]" & vbCrLf & _ " SET [" & arTblName & "].CaseBook = ""فاقد""," & vbCrLf & _ " [" & arTblName & "].[G N] = " & maxGN & vbCrLf & _ " WHERE ((([" & arTblName & "].CaseBook)=""موجود"")" & vbCrLf & _ " AND (Not ([" & arTblName & "].title) Is Null)" & vbCrLf & _ " AND (([" & arTblName & "].searinumber) Between [forms]![F_GardBooks]![text]" & vbCrLf & _ " AND [forms]![F_GardBooks]![text2]))" & vbCrLf & _ " OR ((([" & arTblName & "].CaseBook)=""موجود"")" & vbCrLf & _ " AND (([" & arTblName & "].title) Is Null)" & vbCrLf & _ " AND (([" & arTblName & "].searinumber) Between [forms]![F_GardBooks]![text]" & vbCrLf & _ " AND [forms]![F_GardBooks]![text2]));" If msgResponse = vbOK Then DoCmd.SetWarnings False DoCmd.RunSQL strSQL DoCmd.SetWarnings True MsgBox "تم تحديث البيانات بنجاح والحمد لله" Else End If Exit Sub ErrorHandler: Debug.Print Err.Number; Err.Description End Sub تم إضافة هذه الوظيفة {arTableName} لتعود بإسم الجدول العربي أنصح بإستخدامها كما تم تنسيق الكود قليلاً وإضافة { " [" & arTblName & "].[G N] = " & maxGN } لإضافة التحديث المطلوب بالتوفيق

السلام عليكم جميعا لدي ملف اكسل و اريد عدم سرقته و فتحه في اي جهاز اخر . استخدمت الكود التالي لكنه في كل مرة تظهر لي رسالة التنبه الموجودة في الكود بالرغم من وجود الملف في المسار المحدد له في الكود ارجو منكم ( من اصحاب الخبرة والفكر النير ) مساعدتي في حل هذه المشلكة اما تصحيح الكود او التكرم ببرمجة كود اخر يمنع فتح ملف الاكسل المحدد الا بوجود ملف معين في مسار معين , ولكم من جزيل الشكر والتقدير هذا هو الكود الذي معي في الوقت الحالي لكنه لا يعمل بشكل صحيح: Private Sub Workbook_Open() Dim requiredFile As String Dim filePath As String ' حدد المسار والملف المطلوبين filePath = "C:\Program Files\new\officeteam.txt" requiredFile = "officeteam.txt" ' تحقق من وجود الملف If Dir(filePath & "\" & requiredFile) = "" Then MsgBox "ليس لديك الاذن في الاستخدام, يرجى التواصل مع مالك النظام . تنبيه.", vbCritical ThisWorkbook.Close SaveChanges:=False End If End Sub

وين كانت المشكلة

اللهم بارك فيه وفي علمه وعمله وأجعل عمله خالصاً لك وحدك يارب العالمين اللهم زد وبارك مبارك عليك أخي فادي @Foksh ماشاء الله تبارك الله أعمالك مميزة وجميلة زادك الله حرصاً وإتقاناً بالتوفيق ❤️

@ابو جودي آمين بارك الله فيك، و شكراً جزيلاً لك أخي الكريم اللهم أرضَ عن عبدك وثبته علي دينك @عاشق_الرقي آمين بارك الله فيك، ورزقك علماً نافعاً ينتفع به وأسئل الله العلي القدير أن ينعم عليك ويزيدك من فضله @عمر ضاحى بارك الله فيك وفي علمك وعملك شكراً جزيلاً

ارجو ان تساعدوني في هذا الموضوع

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

السلام عليكم ورحمة الله وبركاته استاذ محمد هشام تحية طيبة وبعد محتاج اعمل vpa نفس اللي حضرتك عامله بس محتاج تعديل علي الشيت المرفق كمثال ان عمود ال c ياخذ من عمود ال c في شيت الداتا وعمود ال d باخذ من عمود ال d في شيت الداتا وعمود ال e باخذ من عمود ال e في شيت الداتا وعمود ال i باخذ من عمود ال i في شيت الداتا وعمود ال j باخذ من عمود ال j في شيت الداتا وعمود ال k باخذ من عمود ال k في شيت الداتا وعمود ال o باخذ من عمود ال o في شيت الداتا وهكذا بنفس الطريقة اللي حضرتك عملت بيها الشيت او الشرح السايق اللي حضرتك عامله تعديل .xlsm

@jjafferr

jjafferr@

وإياكم أستاذنا الكبير ، ونسأل الله أن نكون عند حسن ظنهم . وأن نتعلم من علمكم الذي وهبكم الله إياه . الله يبارك فيك أخي الحبيب .. نتمنى أن نراكم بجانبنا يوماً ما حبيبي مهندس عمر .. الله يبارك فيك ، ونتمنى لكم المضي بجانبنا

اوه اخي @Foksh مبارك لك المنصب الجديد 🌹🌹🌹🌹🌹 كنت اسأل متى هيتم ترقيتك لانك سباق دائما ومبدع 🌹🌹🌹 الف الف مبروك اخي فادي

استاذ @Ahmos مبارك لك اضمامك للاسره الكريمه 🌹🌹🌹🌹 الف مبروك 🌹🌹🌹🌹

أستاذ @Ahmos .. الف مبروك لنا انضمامكم إلى فريق نخبة النخبة .. وأنت من الأشخاص المميزين الذين يستحقون هذا اللقب فعلاً ، جعل الله علمكم صدقة جارية لكم ونسأل الله أن ينعم علينا كما أنعم عليكم بالعطاء ولا نسعى إلى الألقاب فعطائنا لا يقاس بعطائكم بوركت جهودكم

ههههههههه كثروا في النكاش والتناكش فالمستفيد في النهاية (المستهلك ) إللي هوا إحنا طبعاً زادكم الله من فضله وبارك في علمكم

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

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

ارقام مفقودة 2.xlsb

عايز تلعب يعني هههههههه وببدلتي الحمرا 😎 دي لسه جديدة ✌ هروح هناك وأشوف وصلت لفين . أحسن انت خلااااااص بجد وصلت لاخر السكة 🤣

أنت كمان بتضحك حظك لإنى مش فاضى لك بس نكاش بنكاش والبادى أنكش ... وأنت اللى بدأت بئه انا مش فاهم انا بقول ايه شكلى وصلت لاخر السكة خلاص التكة خلصت اتفضل يا سيدى ذاكر وانبسط بما انك عاوز وحده نمطية وتحكم من خلالها بس مش هخليها زيك تخفى العناصر وخلاص لا هخليــ .... وهأتكلم كتير ما تشوف بنفسك المرفق فيه الـ 3 نماذج بتوعك زى ما هم بينفذوا نفس طلباتك بس .......... فى نموذجين تانين ووحدتين نمطيتين شوف انت بقه اللى فيهم وذاكر ولما ابقى أروق لك ونفضى نبقى نتشاكس الموضوع والمرفق : >--->> من هنا يا أستاذ @Foksh طبعا بعيدا عن التهريج والهزار والمزاح لا اقلل من الاجابة الاولى وهى قطعا وبالفعل الأفضل على الإطلاق والإجابة المباشرة ولكن لأن فعلا كان فكرة كنت شغال عليها بالصدفة وتقريبا كانت شبه منتهيه فى ترتيب الأفكار بس فؤش أفندى بقه لعب فى نفوخى قلت لا بقه لازم أنهى الفكرة بالشكل الأمثل وعلشان مرتبطه بالموضوع ده وهو تنفيذ حدث فى وقت محدد أو بين وقتين محددين حبت اهز الورد وأضحك مع أخى الحبيب فؤش أفندى بمناسبة أن دى أول مشاركه لى معه بثوبه الجديد وليكون الموضوع مرجعا لمن يهتم لمثل هذه الأمور المجنونه شويه شويه هتخلونا نعمل كود يعمل اللى بنفكر ونحلم بيه ده اللى ناقص بقه وتبقى كملت مش تقولوا لى كود يعمل اكتر من وظيفه أو وظائف متتعده فى وقت محدد أو فى عدة أوقات مختلفة من إجراء واحد مركزى ايه لعب العيال ده يا فؤش أفندى هههه وأنا مصدقت لاقيته لعب عيال قلت العب براحتى بقه بقالى كتير ما أفوت وأول ما أفوت اشوفك ما شاء الله لابس البدله الحمرا

الوحده النمطية الأولى: bas01:TimeAction المميزات أنواع أحداث وتعليقات قابلة للتوسعة عبر Enum (EventType, ControlVisibility) تحديد توقيت إظهار/إخفاء عناصر النماذج بسهولة عبر الدالة SetControlVisibility تنفيذ إجراءات مؤقتة باستخدام CallTimeAction أو ApplyTimeActions منع التكرار التلقائي للتنفيذ بالدالة الذكية ExecuteDynamicMethod دعم المعاملات وتعددها في الدوال المنفذة (حتى 4 معاملات) تسجيل احترافي للأحداث عبر LogEvent في نافذة Immediate شرط تفعيل DebugMode الهدف : تنفيذ إجراءات مشروطة بالوقت مع إمكانية التنفيذ لمرة واحدة في الجلسة الاستخدام الأمثل :تحكم في ظهور عناصر/عدة عناصر بالنموذج أو تنفيذ إجراء/إجراءات بناء على الوقت اليومي استخدم الكود فى الحالات الآتيـــة : إذا كنت تحتاج إلى تنفيذ إجراءات زمنية عادية ومكررة يوميا إذا كنت لا تمانع في تنفيذ نفس الدالة مرات مختلفة إذا تغيّر التوقيت Option Compare Database Option Explicit ' ========================= ' إعدادات عامة ' ========================= Public DebugMode As Boolean Private dicExecuted As Object ' لتجنب تكرار التنفيذ ' ========================= ' أنواع الأحداث والمظهر ' ========================= Public Enum ControlVisibility visible = 0 Hidden = 1 ErrorState = 2 End Enum Public Enum EventType Information = 0 Warning = 1 [Error] = 2 End Enum ' ========================= ' تهيئة الوحدة ' ========================= Private Sub InitializeModule() If dicExecuted Is Nothing Then Set dicExecuted = CreateObject("Scripting.Dictionary") dicExecuted.CompareMode = vbTextCompare End If End Sub ' ========================= ' إعادة تعيين السجل ' ========================= Public Sub ResetExecutedLog() If Not dicExecuted Is Nothing Then dicExecuted.RemoveAll End Sub ' ========================= ' أدوات مساعدة عامة ' ========================= Public Sub LogEvent(message As String, Optional msgType As EventType = Information) If DebugMode Then Debug.Print Format(Now, "yyyy-mm-dd hh:nn:ss") & " [TimedAction] " & _ Choose(msgType + 1, "INFO", "WARN", "ERR") & ": " & message End If End Sub Private Function IsFormName(ByVal varValue As Variant) As Boolean On Error GoTo ErrHandler If VBA.TypeName(varValue) = "String" Then If SysCmd(acSysCmdGetObjectState, acForm, CStr(varValue)) = acObjStateOpen Then IsFormName = True End If End If Exit Function ErrHandler: IsFormName = False End Function Private Function IsString(v As Variant) As Boolean IsString = (VarType(v) = vbString) End Function Private Function IsBoolean(v As Variant) As Boolean IsBoolean = (VarType(v) = vbBoolean) End Function Private Function IsObject(v As Variant) As Boolean IsObject = (VarType(v) >= vbObject) End Function Public Function ShouldShowControl(Optional TargetTime As Date = #3:00:00 PM#) As Boolean ShouldShowControl = (Time() < TargetTime) End Function Public Function SetControlVisibility(frm As Form, ctlName As String, _ Optional TargetTime As Date = #3:00:00 PM#) As ControlVisibility On Error GoTo ErrorHandler If frm Is Nothing Or Len(Trim(ctlName)) = 0 Then LogEvent "النموذج أو اسم العنصر غير صالح في SetControlVisibility", [Error] SetControlVisibility = ErrorState Exit Function End If Dim ctl As Control Set ctl = frm.Controls(ctlName) If ctl Is Nothing Then LogEvent "العنصر '" & ctlName & "' غير موجود في النموذج", [Error] SetControlVisibility = ErrorState Exit Function End If Dim bolVisible As Boolean bolVisible = ShouldShowControl(TargetTime) ctl.visible = bolVisible SetControlVisibility = IIf(bolVisible, visible, Hidden) Exit Function ErrorHandler: LogEvent "خطأ في SetControlVisibility للعنصر '" & ctlName & "': " & Err.Description, [Error] SetControlVisibility = ErrorState End Function ' ========================= ' تنفيذ ذكي للدوال ' ========================= Private Sub ExecuteDynamicMethod(ByVal objTarget As Object, ByVal strMethodName As String, Optional arrArgs As Variant) On Error GoTo HandleError InitializeModule If Len(Trim(strMethodName)) = 0 Then LogEvent "اسم الدالة فارغ في ExecuteDynamicMethod", [Error] Exit Sub End If If dicExecuted.Exists(strMethodName) Then LogEvent "الدالة '" & strMethodName & "' تم تنفيذها مسبقاً", Warning Exit Sub End If If Not objTarget Is Nothing Then If IsMissing(arrArgs) Or IsEmpty(arrArgs) Then CallByName objTarget, strMethodName, VbMethod Else ExecuteWithParams objTarget, strMethodName, arrArgs End If Else If IsMissing(arrArgs) Or IsEmpty(arrArgs) Then Application.Run strMethodName Else ExecuteRunWithParams strMethodName, arrArgs End If End If dicExecuted(strMethodName) = True LogEvent "تم تنفيذ '" & strMethodName & "' بنجاح", Information Exit Sub HandleError: LogEvent "خطأ في تنفيذ '" & strMethodName & "': " & Err.Number & " - " & Err.Description, [Error] End Sub Private Sub ExecuteWithParams(objTarget As Object, strMethodName As String, params As Variant) On Error GoTo HandleError Dim paramCount As Long, i As Long Dim tempParams() As Variant If IsArray(params) Then paramCount = UBound(params) + 1 ReDim tempParams(paramCount - 1) For i = 0 To paramCount - 1 If IsFormName(params(i)) Then Set tempParams(i) = Forms(params(i)) Else tempParams(i) = params(i) End If LogEvent "معامل " & i & " لـ '" & strMethodName & "': " & CStr(tempParams(i)), Information Next Else paramCount = 1 ReDim tempParams(0) tempParams(0) = params LogEvent "معامل 0 لـ '" & strMethodName & "': " & CStr(tempParams(0)), Information End If Select Case paramCount Case 0: CallByName objTarget, strMethodName, VbMethod Case 1: CallByName objTarget, strMethodName, VbMethod, tempParams(0) Case 2: CallByName objTarget, strMethodName, VbMethod, tempParams(0), tempParams(1) Case 3: CallByName objTarget, strMethodName, VbMethod, tempParams(0), tempParams(1), tempParams(2) Case 4: CallByName objTarget, strMethodName, VbMethod, tempParams(0), tempParams(1), tempParams(2), tempParams(3) Case Else LogEvent "عدد المعاملات أكثر من 4 غير مدعوم في CallByName لـ '" & strMethodName & "'", [Error] End Select Exit Sub HandleError: LogEvent "خطأ في ExecuteWithParams لـ '" & strMethodName & "': " & Err.Description, [Error] End Sub Private Sub ExecuteRunWithParams(strMethodName As String, params As Variant) On Error GoTo HandleError Dim paramCount As Long, i As Long Dim tempParams() As Variant If IsArray(params) Then paramCount = UBound(params) + 1 ReDim tempParams(paramCount - 1) For i = 0 To paramCount - 1 If IsFormName(params(i)) Then Set tempParams(i) = Forms(params(i)) Else tempParams(i) = params(i) End If LogEvent "معامل " & i & " لـ '" & strMethodName & "': " & CStr(tempParams(i)), Information Next Else paramCount = 1 ReDim tempParams(0) tempParams(0) = params LogEvent "معامل 0 لـ '" & strMethodName & "': " & CStr(tempParams(0)), Information End If Select Case paramCount Case 0: Application.Run strMethodName Case 1: Application.Run strMethodName, tempParams(0) Case 2: Application.Run strMethodName, tempParams(0), tempParams(1) Case 3: Application.Run strMethodName, tempParams(0), tempParams(1), tempParams(2) Case 4: Application.Run strMethodName, tempParams(0), tempParams(1), tempParams(2), tempParams(3) Case Else LogEvent "عدد المعاملات أكثر من 4 غير مدعوم في Application.Run لـ '" & strMethodName & "'", [Error] End Select Exit Sub HandleError: LogEvent "خطأ في ExecuteRunWithParams لـ '" & strMethodName & "': " & Err.Description, [Error] End Sub ' ========================= ' التحقق من توقيت التنفيذ ' ========================= Private Function IsTimeMatch(ByVal dtmStart As Date, ByVal dtmEnd As Variant, ByVal bolUseRange As Boolean) As Boolean Dim dtmNow As Date: dtmNow = Time() If IsMissing(dtmEnd) Or IsNull(dtmEnd) Or Not bolUseRange Then IsTimeMatch = (dtmNow >= dtmStart) Else IsTimeMatch = (dtmNow >= dtmStart And dtmNow <= dtmEnd) End If End Function ' ========================= ' تنفيذ الإجراءات المؤقتة ' ========================= Public Sub CallTimeAction(ByVal objTarget As Object, ByVal strMethodName As String, _ ByVal dtmStart As Date, Optional ByVal dtmEnd As Variant, _ Optional ByVal bolUseRange As Boolean = True) On Error Resume Next If IsTimeMatch(dtmStart, dtmEnd, bolUseRange) Then ExecuteDynamicMethod objTarget, strMethodName End If End Sub Public Sub CallTimeActionWithArgs(ByVal objTarget As Object, ByVal strMethodName As String, _ ByVal arrArgs As Variant, ByVal dtmStart As Date, _ Optional ByVal dtmEnd As Variant, _ Optional ByVal bolUseRange As Boolean = True) On Error Resume Next If IsTimeMatch(dtmStart, dtmEnd, bolUseRange) Then ExecuteDynamicMethod objTarget, strMethodName, arrArgs End If End Sub Public Sub ApplyTimeActions(ByVal objTarget As Object, ByVal arrActions As Variant) InitializeModule Dim arrItem As Variant For Each arrItem In arrActions If Not IsArray(arrItem) Then LogEvent "العنصر في arrActions ليس مصفوفة صالحة", [Error] GoTo ContinueLoop End If Dim strMethod As String: strMethod = arrItem(0) Dim lngUB As Long: lngUB = UBound(arrItem) Dim arrArgs As Variant: arrArgs = Empty Dim dtmStart As Date Dim dtmEnd As Variant: dtmEnd = Null Dim bolUseRange As Boolean: bolUseRange = True If lngUB < 1 Then LogEvent "بيانات غير كافية للإجراء '" & strMethod & "'", [Error] GoTo ContinueLoop End If If IsArray(arrItem(1)) Then arrArgs = arrItem(1) dtmStart = arrItem(2) If lngUB >= 3 Then dtmEnd = arrItem(3) If lngUB >= 4 Then bolUseRange = arrItem(4) ' فحص المعاملات If strMethod = "HideControlByName" And UBound(arrArgs) >= 0 Then If Not IsString(arrArgs(0)) Then LogEvent "معامل HideControlByName ليس سلسلة نصية: " & CStr(arrArgs(0)), [Error] GoTo ContinueLoop End If ElseIf strMethod = "ComplexMsgBox" And UBound(arrArgs) >= 2 Then If Not IsString(arrArgs(0)) Or Not IsBoolean(arrArgs(1)) Or Not IsObject(arrArgs(2)) Then LogEvent "معاملات ComplexMsgBox غير صالحة: " & Join(arrArgs, ","), [Error] GoTo ContinueLoop End If ElseIf strMethod = "LocalMsg" And UBound(arrArgs) >= 1 Then If Not IsString(arrArgs(0)) Or Not IsString(arrArgs(1)) Then LogEvent "معاملات LocalMsg غير صالحة: " & Join(arrArgs, ","), [Error] GoTo ContinueLoop End If End If CallTimeActionWithArgs objTarget, strMethod, arrArgs, dtmStart, dtmEnd, bolUseRange Else dtmStart = arrItem(1) If lngUB >= 2 Then dtmEnd = arrItem(2) If lngUB >= 3 Then bolUseRange = arrItem(3) CallTimeAction objTarget, strMethod, dtmStart, dtmEnd, bolUseRange End If ContinueLoop: Next End Sub ' ========================= ' مثال استخدام ComplexMsgBox ' ========================= Public Sub ComplexMsgBox(ByVal strVal As String, ByVal bolFlag As Boolean, ByVal frm As Form) If bolFlag Then MsgBox "تم تنفيذ الإجراء على النموذج: " & frm.Name & " باستخدام القيمة: " & strVal End If End Sub -------------------------- الوحده النمطية الثانية : bas02:TimeExecutionKeyed المميزات تنفيذ ذكي مشروط بالوقت باستخدام TimedRunWithKey منع التكرار التام بفضل المفتاح الفريد (ExecutionKey) تعامل مرن مع الإجراءات بحد أقصى 4 معاملات بناء مفتاح فريد يجمع اسم الدالة والمعاملات والتوقيت الهدف : تنفيذ إجراءات مشروطة بالوقت وعدم تكرارها أبدا إذا تكررت المدخلات الاستخدام الأمثل : عندما تريد تنفيذ سيناريوهات متعددة و تحتاج لمنع تكرار تنفيذ نفس الإجراء بنفس المعلمات تماما استخدم الكود فى الحالات الآتيـــة : إذا كنت تريد ضمان عدم تكرار نفس الإجراء بنفس الظروف بشكل صارم (مثل تسجيل حركة مرة واحدة فقط لكل توقيت) إذا كنت تحتاج تتبع وتنفيذ ذكي مبني على مفتاح فريد Option Compare Database Option Explicit Private dicExecuted As Object ' ========== التهيئة ========== Private Sub InitializeModule() If dicExecuted Is Nothing Then Set dicExecuted = CreateObject("Scripting.Dictionary") dicExecuted.CompareMode = vbTextCompare End If End Sub Public Sub ResetExecutedLog() If Not dicExecuted Is Nothing Then dicExecuted.RemoveAll End Sub ' ========== أدوات مساعدة ========== Private Function ToSafeString(val As Variant) As String If IsObject(val) Then On Error Resume Next ToSafeString = TypeName(val) Exit Function End If If IsNull(val) Then ToSafeString = "<NULL>" Else ToSafeString = CStr(val) End If End Function Private Function BuildExecutionKey(ByVal strMethod As String, ByVal arrArgs As Variant, _ ByVal dtmStart As Date, ByVal dtmEnd As Variant) As String Dim arrParts() As String Dim i As Long ReDim arrParts(0) arrParts(0) = strMethod If IsArray(arrArgs) Then For i = 0 To UBound(arrArgs) ReDim Preserve arrParts(UBound(arrParts) + 1) arrParts(UBound(arrParts)) = ToSafeString(arrArgs(i)) Next ElseIf Not IsMissing(arrArgs) Then ReDim Preserve arrParts(UBound(arrParts) + 1) arrParts(UBound(arrParts)) = ToSafeString(arrArgs) End If ReDim Preserve arrParts(UBound(arrParts) + 1) arrParts(UBound(arrParts)) = Format(dtmStart, "hh:nn:ss") If Not IsMissing(dtmEnd) And Not IsNull(dtmEnd) Then ReDim Preserve arrParts(UBound(arrParts) + 1) arrParts(UBound(arrParts)) = Format(dtmEnd, "hh:nn:ss") End If BuildExecutionKey = Join(arrParts, "|") End Function Private Function AlreadyExecuted(strExecKey As String) As Boolean AlreadyExecuted = dicExecuted.Exists(strExecKey) End Function Private Sub MarkExecuted(strExecKey As String) dicExecuted(strExecKey) = True End Sub Private Sub Log(ByVal msg As String, Optional msgType As String = "INFO") If DebugMode Then Debug.Print Format(Now, "yyyy-mm-dd hh:nn:ss") & " [TimedActionKey] " & msgType & ": " & msg End Sub Private Function IsTimeMatch(ByVal dtmStart As Date, ByVal dtmEnd As Variant, ByVal bolUseRange As Boolean) As Boolean Dim dtmNow As Date: dtmNow = Time() If IsMissing(dtmEnd) Or IsNull(dtmEnd) Or Not bolUseRange Then IsTimeMatch = (dtmNow >= dtmStart) Else IsTimeMatch = (dtmNow >= dtmStart And dtmNow <= dtmEnd) End If End Function Private Sub RunWithArgs(ByVal objTarget As Object, ByVal strMethod As String, arrArgs As Variant) On Error GoTo HandleError If objTarget Is Nothing Then Select Case UBound(arrArgs) Case 0: Application.Run strMethod, arrArgs(0) Case 1: Application.Run strMethod, arrArgs(0), arrArgs(1) Case 2: Application.Run strMethod, arrArgs(0), arrArgs(1), arrArgs(2) Case 3: Application.Run strMethod, arrArgs(0), arrArgs(1), arrArgs(2), arrArgs(3) Case Else: Log "أكثر من 4 معاملات غير مدعومة لـ " & strMethod, "ERR" End Select Else Select Case UBound(arrArgs) Case 0: CallByName objTarget, strMethod, VbMethod, arrArgs(0) Case 1: CallByName objTarget, strMethod, VbMethod, arrArgs(0), arrArgs(1) Case 2: CallByName objTarget, strMethod, VbMethod, arrArgs(0), arrArgs(1), arrArgs(2) Case 3: CallByName objTarget, strMethod, VbMethod, arrArgs(0), arrArgs(1), arrArgs(2), arrArgs(3) Case Else: Log "أكثر من 4 معاملات غير مدعومة لـ " & strMethod, "ERR" End Select End If Exit Sub HandleError: Log "خطأ في تنفيذ " & strMethod & ": " & Err.Number & " - " & Err.Description, "ERR" End Sub ' ========== الدالة الرئيسية ========== Public Sub TimedRunWithKey(ByVal objTarget As Object, ByVal strMethod As String, _ ByVal arrArgs As Variant, ByVal dtmStart As Date, _ Optional ByVal dtmEnd As Variant, _ Optional ByVal bolUseRange As Boolean = True) InitializeModule If Not IsTimeMatch(dtmStart, dtmEnd, bolUseRange) Then Exit Sub Dim strKey As String strKey = BuildExecutionKey(strMethod, arrArgs, dtmStart, dtmEnd) If AlreadyExecuted(strKey) Then Log "تخطي التنفيذ المكرر لـ " & strMethod, "WARN" Exit Sub End If RunWithArgs objTarget, strMethod, arrArgs MarkExecuted strKey Log "تم التنفيذ بـ Key: " & strKey End Sub ' For Tesr Public Sub TestMsgProc(ByVal strMsg As String, ByVal bolShow As Boolean) If bolShow Then MsgBox "تم التنفيذ: " & strMsg, vbInformation, "اختبار" Else Debug.Print "? تم تجاهل الإظهار ولكن التنفيذ تم: " & strMsg End If End Sub وأخيرا المرفق TimedAction.accdb