ابو جودي

السلام عليكم انا مررت سريعا ولكن الى ان اعود مرة اخرى لانشغالى الشديد الان انظر الى هذا المرفق ان شاء الله تعالى قد تجد فيه افكار قد تعجبكم الذكر الحكيم.zip

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

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

سؤال لولبى شوف يا استاذى الحبيب واخى الجميل زى ما بينحكى انا اعطيتكم المكونات الرئيسية اما الطبخه عليكم طيب اجابة السؤال كالتالى : الكود لا يعتمد فى هذا الشكل على اى بيانات ولا هيكله ولا فى النموذج حاولت اعمل كل خطوة فى النموذج منفرده للتجربة وبما ان النموذج غير منضم وبما ان هيكل الكود لا يحتوى على اى بيانات ولا على اى ثوابت لبيانات تخص الاتصال بجهاز على الشبكة اذن عند نقل القاعدة لاى حاسوب لن يكون لها اى تأثير يذكر على نظام التشغيل الجديد الا اذا قمت باضافة بيانات من خلال النموذج طيب الفكرة الصحيحة او الطبخة المعتبرة : عمل جدول اعدادات الاتصال بالسيرفر يحتوى على بيانات اعتماد الاتصال ( اسم الجهاز او الـ IP + اسم المستخدم و كلمة المرور لهذا المستخدم ) وعمل نموذج اولى الخطوة الأولـى : اضافة بيانات الاعتماد الخاصة بالاتصال بالجهاز على الشبكة المحلية ومتقلقش مش هيتم تكرار للبيانات فى Windows Credential الخطوة الثانية : اعادة الارتباط بالجداول طيب طول ما البيانات موجوده فى الجدول وطول ما ان الجهاز السيرفر لم يتغير اسمه او لم يتغير ال IP الخاص به حسب حسب مسار المجلد الشبكى سوف تعمل على هذا النهج حتى لو تم نقلها الى حاسوب جديد كليا طبعا فى حال نقل القاعدة الى شبكة أخرى فى مكان اخر او تغير اسم الحاسوب او بيانات الاتصال يتم تحديثها فى الجدول

في بيئات العمل الحديثة التي تعتمد على الشبكات المحلية، يُعد الاتصال المستقر بقاعدة البيانات الخلفية أمرًا أساسيًا لاستمرارية العمليات اليومية. ومع ذلك، تظهر أحيانًا مشكلات تقنية تتعلق بفقدان بيانات الاعتماد (اسم المستخدم وكلمة المرور) الخاصة بالوصول إلى مجلدات شبكية تحتوي على قاعدة البيانات ويتم الاتصال بالشبكات أو الأجهزة عبر البروتوكولات مثل RDP أو SMB. تخيل هذا السيناريو: · جهاز جديد ينضم إلى الشبكة. · أحد الأجهزة يتعرض لعطل مفاجئ، أو يتم إعادة تشغيله رغم تفعيل خيار "تذكر بيانات الاعتماد"، يفقد النظام هذه البيانات بعد التشغيل، مما يؤدي إلى انقطاع الاتصال بقاعدة البيانات وتعطل سير العمل. الحل: أداة متقدمة لإدارة بيانات الاعتماد تم تطوير كود ذكي لمعالجة هذه المشكلة بفعالية وكفاءة، من خلال : تخزين بيانات الاتصال (العنوان - اسم المستخدم - كلمة المرور) داخل نظام Windows Credential Manager المدمج في نظام التشغيل. أبرز المميزات: · سهولة الاستخدام: وظائف جاهزة لإضافة، وحذف بيانات الاعتماد بضغطة واحدة، دون الحاجة لأي معرفة برمجية. · ثبات الاتصال: يتم حفظ بيانات الاعتماد بشكل دائم حتى بعد إعادة تشغيل الجهاز، مما يضمن استمرارية الاتصال بقواعد البيانات دون الحاجة لإعادة الإدخال يدويًا. · توافق واسع: متوافق مع أنظمة Windows وOffice بنواتيها 32-بت و64-بت، ما يضمن عمله في مختلف بيئات العمل بدون مشاكل توافق. فوائد الكود: · توفير الوقت بإلغاء الحاجة إلى إدخال بيانات الاعتماد بشكل متكرر. · ضمان اتصال دائم وموثوق مع الشبكة وقواعد البيانات. · إمكانية التخصيص ليتناسب مع احتياجات كل مستخدم أو مؤسسة. · مناسب لجميع المستخدمين سواء المبتدئين أو المحترفين. الخاتمة: لا تدع مشكلات الشبكة تعرقل سير العمل. باستخدام هذه الأداة، يمكنك إدارة بيانات الاعتماد بكل كفاءة وأمان، مما يضمن اتصالًا ثابتًا ومستقرًا بقاعدة بياناتك في جميع الأوقات. إنها الحل المثالي لتطبيقات الشبكات المحلية التي تعتمد على الاتصال المستمر والسلس بقواعد البيانات. صور توضح مكان حفظ أو جلب بيانات الاعتماد من النظام: للتأكيد هنا نتعامل مع Windows Credentials وذلك لادارة بيانات اعتماد خاصة بتسجيل الدخول في نطاق (Domain) خاص بـ Windows مثل كلمات المرور المستخدمة لتسجيل الدخول إلى الشبكات أو الأجهزة عبر البروتوكولات مثل RDP أو SMB الكود الخاص بإدارة البيانات ( إضافة / حذف ) سوف نضع وحده نمطية باسم : basCredentialsmanager Option Compare Database Option Explicit '=========================== ' إضافة بيانات Credential '=========================== Public Function AddWindowsCredential(ByVal strTarget As String, ByVal strUserName As String, ByVal strPassword As String) As Boolean Dim strCommand As String Dim lngExitCode As Long strCommand = "cmd.exe /c cmdkey /add:" & strTarget & " /user:""" & strUserName & """ /pass:""" & strPassword & """ && exit 0 || exit 1" lngExitCode = ExecuteAndWait(strCommand, WindowHidden, True) AddWindowsCredential = (lngExitCode = 0) End Function '=========================== ' حذف بيانات Credential '=========================== Public Function DeleteWindowsCredential(ByVal strTarget As String) As Boolean Dim strCommand As String Dim lngExitCode As Long strCommand = "cmd.exe /c cmdkey /delete:""" & strTarget & """ && exit 0 || exit 1" lngExitCode = ExecuteAndWait(strCommand, WindowHidden, True) DeleteWindowsCredential = (lngExitCode = 0) End Function ' وظيفة للتحقق من أن السلسلة غير فارغة وخالية من محرف Null Public Function ValidateString(strInput As String) As Boolean ' أولاً، تحقق من أن السلسلة ليست فارغة بعد إزالة المسافات الزائدة ValidateString = Len(Trim(strInput)) > 0 ' إذا كانت السلسلة ليست فارغة، تحقق من عدم وجود محرف Null (vbNullChar) If ValidateString Then ValidateString = InStr(strInput, vbNullChar) = 0 End If End Function ' ==================================================== ' أمثلة لدوال اختبار الكود ' ==================================================== ' ==================================================== ' إضافة بيانات اعتماد (اسم مستخدم وكلمة مرور) ' ==================================================== Public Sub TestAddWindowsCredential() Dim strNetworkAddress As String Dim strNetworkUserName As String Dim strNetworkPassword As String Dim blnSuccess As Boolean ' بيانات اعتماد تجريبية strNetworkAddress = "TestTarget0123" strNetworkUserName = "TestUser0123" strNetworkPassword = "TestPass0123" ' استدعاء دالة الإضافة blnSuccess = AddWindowsCredential(strNetworkAddress, strNetworkUserName, strNetworkPassword) ' عرض النتيجة If blnSuccess Then MsgBox "تمت إضافة بيانات الاعتماد بنجاح.", vbInformation, "نجاح" Else MsgBox "تعذر إضافة بيانات الاعتماد.", vbInformation, "تنبيــه" End If End Sub ' ==================================================== ' حذف بيانات الاعتماد المخزنة ' ==================================================== Public Sub TestDeleteWindowsCredential() Dim strNetworkAddress As String Dim blnSuccess As Boolean ' العنوان الذي نريد حذف بياناته strNetworkAddress = "TestTarget0123" ' استدعاء دالة الحذف blnSuccess = DeleteWindowsCredential(strNetworkAddress) ' عرض النتيجة If blnSuccess Then MsgBox "تم حذف بيانات الاعتماد بنجاح.", vbInformation, "نجاح" Else MsgBox "تعذر حذف بيانات الاعتماد. تأكد من تسجيل الجهاز مسبقًا.", vbInformation, "تنبيــه" End If End Sub ولضمان التحكم الدقيق في إجراء العمليات وإرجاع النتائج سوف نعتمد على دالة : تعرف او شائعه لدى المطورين باسم : ShellWait وتم تناولها فى هذا الموضوع بالتفصيل لمن يريد العودة اليها إضافة وحدة نمطية عامة باسم : basShellExecutor الكود Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit '======================================================================================================================= '------ الثوابت Public Const PROCESS_TIMEOUT_INFINITE As Long = &HFFFFFFFF Public Const PROCESS_STILL_ACTIVE As Long = &H103 Public Const PROCESS_TERMINATED As Long = vbObjectError Or &HDEAD Public Const MAX_PATH_LENGTH As Long = 260 Public Const QS_ALL_INPUT As Long = &H4FF Private Const ERR_NO_COMMAND As Long = vbObjectError Or 1001 Private Const ERR_EXECUTING As Long = vbObjectError Or 1002 Private Const ERR_EXECUTION_FAILED As Long = vbObjectError Or 1003 Private Const ERR_TERMINATION_FAILED As Long = vbObjectError Or 1004 Private Const SHELL_MASK_NOCLOSEPROCESS As Long = &H40 Private Const SHELL_MASK_DOENVSUBST As Long = &H200 Private Const SHELL_MASK_SUPPRESS_ERRORS As Long = &H400 Private Const PROCESS_QUERY_INFO As Long = &H400 Private Const PROCESS_SYNCHRONIZE As Long = &H100000 Private Const PROCESS_TERMINATE As Long = &H1 Private Const ERROR_ACCESS_DENIED As Long = 5 '======================================================================================================================= '------ التعدادات Public Enum ShellWindowStyle WindowHidden = 0 WindowNormal = 1 WindowMinimized = 2 WindowMaximized = 3 WindowNoActivate = 4 End Enum '======================================================================================================================= '------ الأنواع المخصصة #If VBA7 Then Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As LongPtr Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As LongPtr ItemListPointer As LongPtr ClassName As String ClassKeyHandle As LongPtr HotKey As Long IconHandle As LongPtr ProcessHandle As LongPtr End Type #Else Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As Long Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As Long ItemListPointer As Long ClassName As String ClassKeyHandle As Long HotKey As Long IconHandle As Long ProcessHandle As Long End Type #End If '======================================================================================================================= '------ تعريفات API #If VBA7 Then Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr ' فتح مقبض العملية Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long ' إغلاق مقبض العملية Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As LongPtr, Optional ByVal lpDst As LongPtr, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As LongPtr, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As LongPtr) As LongPtr ' إنشاء مؤقت قابل للانتظار Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As LongPtr) As Long ' جلب معرف العملية Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As Long ' تبسيط المسار Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr ' استخراج المعاملات من المسار Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As LongPtr, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As LongPtr, Optional ByVal lpArgToCompletionRoutine As LongPtr, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As Long ' تنفيذ أمر عبر Shell Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long ' إعادة تخصيص السلسلة Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) ' إزالة المعاملات من المسار Private Declare PtrSafe Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #Else Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long ' فتح مقبض العملية Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long ' إغلاق مقبض العملية Private Declare Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long ' إنشاء مؤقت قابل للانتظار Private Declare Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long ' جلب معرف العملية Private Declare Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As Long ' تبسيط المسار Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long ' استخراج المعاملات من المسار Private Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As Long ' تنفيذ أمر عبر Shell Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long ' إعادة تخصيص السلسلة Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) ' إزالة المعاملات من المسار Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #End If '======================================================================================================================= '------ المتغيرات العامة و الخاصة Public g_TerminateLoops As Boolean ' متغير للتحكم في إنهاء الحلقات يدويًا Private m_IsExecuting As Boolean ' علامة لمنع التداخل أثناء التنفيذ '======================================================================================================================= '------------------------------------------- الدوال العامة ' تشغيل أمر والانتظار حتى ينتهي مع استجابة الواجهة Public Function ExecuteAndWait(ByVal CommandLine As String, _ Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, _ Optional ByVal RunAsAdmin As Boolean = False, _ Optional ByVal MaxWaitMs As Long = PROCESS_TIMEOUT_INFINITE) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteAndWait", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ' توسيع متغيرات البيئة ExpandedPath = ExpandEnvVars(CommandLine) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteAndWait", "فشل في تنفيذ الأمر: " & CommandLine End If ProcessHandle = .ProcessHandle End With startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If MaxWaitMs <> PROCESS_TIMEOUT_INFINITE Then If (GetTickCount - startTime) > MaxWaitMs Then Debug.Print "تجاوز الحد الأقصى للانتظار: " & MaxWaitMs & " ميلي ثانية" Exit Do End If End If Loop ExecuteAndWait = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteAndWait", Err.Description End Function ' دالة لتنفيذ أمر مع مهلة زمنية اختيارية وخيار التشغيل كمسؤول Public Function ExecuteWithTimeout(Command As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal TimeoutMs As Long, Optional ByVal RunAsAdmin As Boolean = False, Optional RetryCount As Long = 0) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long Dim RetryIndex As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteWithTimeout", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ExpandedPath = ExpandEnvVars(Command) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If For RetryIndex = 0 To RetryCount With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then If RetryIndex = RetryCount Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteWithTimeout", "فشل في تنفيذ الأمر بعد " & RetryCount + 1 & " محاولات: " & Command End If Else ProcessHandle = .ProcessHandle Exit For End If End With Next RetryIndex startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If TimeoutMs > 0 Then If (GetTickCount - startTime) > TimeoutMs Then If TerminateProcess(ProcessHandle, PROCESS_TERMINATED) = 0 Then Debug.Print "فشل في إنهاء العملية بعد تجاوز المهلة" End If ExitCode = PROCESS_TERMINATED Exit Do End If End If If g_TerminateLoops Then Exit Do Loop ExecuteWithTimeout = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteWithTimeout", Err.Description End Function ' دالة لتشغيل أمر باستخدام WScript.Shell مع خيار الانتظار Public Function ExecuteWScript(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal WaitForCompletion As Boolean = False) As Long Dim WScriptShell As Object On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") ExecuteWScript = WScriptShell.Run(CommandLine, WindowStyle, WaitForCompletion) Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description Err.Raise Err.Number, "ExecuteWScript", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function ' دالة محسنة لتشغيل أمر باستخدام WScript.Shell والتقاط الناتج Public Function ExecuteWScriptCapture(ByVal CommandLine As String) As String Dim WScriptShell As Object Dim ShellExec As Object Dim Output As String On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") Set ShellExec = WScriptShell.Exec(CommandLine) Do While ShellExec.Status = 0 DoEvents Loop Output = ShellExec.StdOut.ReadAll ExecuteWScriptCapture = Output Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description ExecuteWScriptCapture = "" Err.Raise Err.Number, "ExecuteWScriptCapture", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function '======================================================================================================================= '------ الدوال المساعدة ' دالة لتوسيع متغيرات البيئة في سلسلة (مثل %windir%) Private Function ExpandEnvVars(ByVal Path As String) As String Dim Buffer As String Dim Length As Long If InStr(Path, "%") Then Length = ExpandEnvironmentStringsW(StrPtr(Path), 0, 0) If Length > 0 Then Buffer = String$(Length - 1, vbNullChar) If ExpandEnvironmentStringsW(StrPtr(Path), StrPtr(Buffer), Length) Then ExpandEnvVars = Left$(Buffer, Length - 1) Else Debug.Print "فشل توسيع متغيرات البيئة، يتم إرجاع المسار الأصلي: " & Path ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If End Function ' دالة لتبسيط المسار (مثل حل النقاط . و ..) Private Function CanonicalizePath(ByVal Path As String) As String Dim TempPath As String If InStr(Path, "\.") Or InStr(Path, ".\") Then If Len(Path) < MAX_PATH_LENGTH Then TempPath = String$(MAX_PATH_LENGTH - 1, vbNullChar) If PathCanonicalizeW(StrPtr(TempPath), StrPtr(Path)) Then CanonicalizePath = Left$(TempPath, InStr(TempPath, vbNullChar) - 1) Else Debug.Print "فشل تبسيط المسار، يتم إرجاع المسار الأصلي: " & Path CanonicalizePath = Path End If Else CanonicalizePath = Path End If Else CanonicalizePath = Path End If End Function ' دالة لاستخراج المعاملات من المسار Private Function ExtractArguments(ByRef Path As String) As String SysReAllocString VarPtr(ExtractArguments), PathGetArgsW(StrPtr(Path)) If LenB(ExtractArguments) Then PathRemoveArgsW StrPtr(Path) If InStr(ExtractArguments, """") Then ExtractArguments = Replace(ExtractArguments, """", """""") End If End Function ' دالة مساعدة لاستخراج اسم العملية من الأمر Private Function ExtractProcessName(ByVal CommandLine As String) As String Dim Parts() As String Dim FirstPart As String If Left(CommandLine, 1) = """" Then FirstPart = Mid(CommandLine, 2, InStr(2, CommandLine, """") - 2) Else Parts = Split(CommandLine, " ") FirstPart = Parts(0) End If ExtractProcessName = Mid(FirstPart, InStrRev(FirstPart, "\") + 1) End Function ' دالة لإنهاء عملية باستخدام WMI بناءً على اسم العملية Public Function KillProcess(sProcessName As String, Optional sHost As String = ".") As Boolean On Error GoTo Error_Handler Dim oWMI As Object Dim sWMIQuery As String Dim oCols As Object Dim oCol As Object Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2") sWMIQuery = "SELECT Name FROM Win32_Process" Set oCols = oWMI.ExecQuery(sWMIQuery) For Each oCol In oCols If LCase(sProcessName) = LCase(oCol.Name) Then oCol.Terminate End If Next oCol KillProcess = True Error_Handler_Exit: On Error Resume Next Set oCol = Nothing Set oCols = Nothing Set oWMI = Nothing Exit Function Error_Handler: Debug.Print "خطأ في KillProcess: " & Err.Description & " - رقم الخطأ: " & Err.Number KillProcess = False Resume Error_Handler_Exit End Function '======================================================================================================================= '------ أمثلة الاستدعاء ' مثال لاستدعاء ExecuteAndWait ' يفتح Notepad وينتظر إغلاقه Sub TestExecuteAndWait() Dim ExitCode As Long On Error Resume Next ExitCode = ExecuteAndWait("notepad.exe C:\test.txt", WindowNormal) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "رمز الخروج: " & ExitCode Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout ' يفتح الحاسبة وينتظر 5 ثوانٍ كحد أقصى Sub TestExecuteWithTimeout() Dim ProcessId As Long On Error Resume Next ProcessId = ExecuteWithTimeout("paint.exe", WindowMaximized, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript ' يشغل أمر dir في CMD وينتظر النتيجة Sub TestExecuteWScript() Dim Result As Long On Error Resume Next Result = ExecuteWScript("cmd.exe /c dir", WindowNormal, True) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript مع إبقاء النافذة مفتوحة Sub TestExecuteWScript_KeepOpen() Dim Result As Long ' استخدام /k بدلاً من /c لإبقاء نافذة CMD مفتوحة بعد تنفيذ الأمر On Error Resume Next Result = ExecuteWScript("cmd.exe /k dir", WindowNormal, False) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout لتشغيل CMD Sub TestExecuteWithTimeoutCMD() Dim ProcessId As Long ' تشغيل CMD مع أمر dir وانتظار 5 ثوانٍ كحد أقصى On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout مع RunAsAdmin وإعادة المحاولة Sub TestExecuteWithTimeoutAdmin() Dim ProcessId As Long ' تشغيل CMD كمسؤول وانتظار 5 ثوانٍ كحد أقصى مع محاولتين On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000, True, 2) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScriptCapture Sub TestExecuteWScriptCapture() Dim CommandOutput As String ' تنفيذ أمر dir والتقاط الناتج On Error Resume Next CommandOutput = ExecuteWScriptCapture("cmd.exe /c dir") Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "ناتج الأمر:" & vbCrLf & CommandOutput Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub وأخيرا المرفق ملاحظة: تم تعديل المرفق والموضوع بتاريخ : 02/06/2025 Credential Manager.accdb

أستاذي الجليل و معلمي القدير و والدى الحبيب الأستاذ @ابوخليل أستاذي الجليل و معلمى القدير @kkhalifa1960 اليكم المرفق للتجربة يدعم التعامل مع التقارير والنماذج والاستعلامات من نفس الداله وبنفس اساليب واشكال الاستدعاء تم دعم التصدير لـ ( بى دى اف , ورد , اكسل ) المسار الافتراضى قاعدة البيانات او تمرير مسار كــ بـــراميتر تم دعم التعامل كذلك مع الاستعلامات NavigateObjects(V3.2).accdb

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

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

صف جمب أخوك @Moosak تانى هأعمل حالى مش شايف الحمد لله ان ما حد فاهم نعم انا افضل ذلك لا علاقه لها بالخصائص علشان تفهم المقصود منها روح للنموذج : FormA اعتبر انك تريد فتح نموذج ثم فى مربع النص اللى عنوانه على النموذج : OpenArgs Value اكتب فيه التالى : Foksh ثم اضغط زر الامر : بعنوان Open Form ( B ) DialogMode وانظر الى الى النموذج FormB انظر بعد الفتح ما سوف يتم تمريره الى نفس مربع النص فى ها النموذج اعد نفس الخطوات مع تغيير السطر : NavigateForm "", "FormB", DialogMode, strOpenArgsValue لزر الامر : بعنوان Open Form ( B ) DialogMode والموجود فى النموذج FormA الى : NavigateForm "", "FormB", , strOpenArgsValue سوف تجد انه يتم فتح النموذج بالشكل الطبيعى فى كلا الحالتان لا يوجد تغيير فى خصائص النموذج ولكن فى الحاله الاولى سلوك النموذج ديلوج فى انتظار بينات لاتمام العمليات فقط لا غير هذا هو المقصود بالسلوك هذا الحدث لا يغير السلوك او لا يحدد السلوك ولكن يتم قراءة القيم من خلاله فقط والتى تم تمريرها مسبقا وفقط تحدد كيف تريد التعامل معها هل فلتر هل تمرير نص هل تمرير قيم هل تغيير عنوان النموذج مثلا

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

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

استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @jjafferr كل الفضل لكم ولأساتذتي العظماء بعد رب العزة سبحانه وتعالي انتم الضياء الذى يضئ ظلمات جهلنا والنجوم التي بها نهتدى جزاكم الله خيـــرا

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

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

هل تبحثون عن طريقة مرنة وقوية للتحكم في فتح وإغلاق النماذج في قواعد البيانات ؟ إليكم دالة NavigateForm الحل الأمثل لتبسيط إدارة فتح وإغلاق النماذج أو التبديل بين الفتح/والإغلاق بكفاءة عالية! ما هي دالة NavigateForm ؟ NavigateForm هي دالة تستخدم في وحدة نمطية عامة (Module) لإدارة النماذج بطريقة احترافية تقوم الدالة بـالآتي : إغلاق النموذج الحالي أو نموذج محدد فتح نموذج آخر بوضع عرض محدد (مثل العرض العادي - الحوار - التصميم - المخفي - . . . .. إلخ) التبديل بإغلاق نموذج وفتح أخر أو فتح نموذج أخر مع الابقاء على النموذج الأب مفتوح تطبيق فلاتر عبر WhereCondition لتحديد السجلات المعروضة تمرير بيانات إضافية عبر OpenArgs لتخصيص سلوك النموذج الدالة مثالية للمطورين اللي عايزين تنقل سلس بين النماذج مع تحكم دقيق في أوضاع الفتح والإغلاق سواء في تطبيقات بسيطة أو معقدة مميزات دالة NavigateForm مرونة عالية: تدعم إغلاق النموذج الحالي أو إغلاق نموذج محدد أو فتح نموذج بوضع معين أو الجمع بين العمليات دي في استدعاء واحد تعداد مخصص (FormOpenMode): يشمل كل أوضاع فتح النماذج الشائعة: - DefaultMode: الوضع الافتراضي - NormalMode: العرض العادي (Form View) - DesignMode: وضع التصميم (Design View) - DatasheetMode: عرض ورقة البيانات (Datasheet View) - PreviewMode: معاينة الطباعة (Print Preview) - LayoutMode: عرض التخطيط (Layout View) - AddMode: إضافة سجل جديد - EditMode: تعديل السجلات - ReadOnlyMode: القراءة فقط - HiddenMode: فتح النموذج في الوضع المخفي - DialogMode: فتح النموذج كحوار (يوقف تنفيذ الكود حتى الإغلاق) معالجة الأخطاء: تتضمن معالجة أخطاء مدمجة للتعامل مع حالات زي: - أسماء نماذج غير موجودة - محاولة إغلاق نموذج غير مفتوح - أخطاء تشغيل غير متوقعة التعامل مع الإغلاق اليدوي: الدالة بتتعامل بذكاء مع إغلاق النماذج يدويًا (مثل ضغط "X" في النافذة) وبتضمن إمكانية إعادة فتح النموذج بدون مشاكل منع الاستدعاءات المتكررة: بتمنع فتح النموذج مرتين بنفس المعاملات لو كان مفتوح بالفعل، مع إعادة تعيين السجل بعد كل عملية توثيق احترافي: الكود مرفق بتوثيق مفصل يشرح المعاملات و الأوضاع و وأمثلة الاستدعاء سهولة التكامل: يمكن استدعاؤها من أحداث النماذج (مثل أزرار OnClick) أو ماكرو أو كود VBA آخر دعم الفلاتر والبيانات الإضافية: بتسمح بتطبيق فلاتر عبر WhereCondition وتمرير بيانات مخصصة عبر OpenArgs الكود الكود متاح في وحدة نمطية عامة (basNavigateForm)، ويتضمن: تعداد FormOpenMode لتحديد أوضاع الفتح دالة IsFormPresent للتحقق من وجود النموذج دالة NavigateForm لإدارة فتح وإغلاق النماذج Option Compare Database Option Explicit ' متغير عام للتحكم في طباعة رسائل التصحيح Public DebugPrintEnabled As Boolean ' تعداد لتحديد أوضاع فتح النموذج Public Enum FormOpenMode DefaultMode = 0 ' الوضع الافتراضي (يفتح النموذج بإعدادات Access الافتراضية) NormalMode = 1 ' العرض العادي (Form View) DesignMode = 2 ' وضع التصميم (Design View) DatasheetMode = 3 ' عرض ورقة البيانات (Datasheet View) PreviewMode = 4 ' عرض معاينة الطباعة (Print Preview) LayoutMode = 5 ' عرض التخطيط (Layout View) AddMode = 6 ' وضع إضافة سجل جديد EditMode = 7 ' وضع تعديل السجلات ReadOnlyMode = 8 ' وضع القراءة فقط HiddenMode = 9 ' الوضع المخفي (Hidden) DialogMode = 10 ' وضع الحوار (Dialog) End Enum ' ======================================================================= ' الدالة: التحقق من وجود نموذج في قاعدة البيانات ' الوصف: ترجع True إذا كان النموذج موجودًا في قاعدة البيانات، وFalse إذا لم يكن موجودًا ' المعاملات: formName (String) - اسم النموذج المراد التحقق منه ' ' المؤلف: [ابو جودي - منتديات أوفيسنا] ' تاريخ الإنشاء: 24 مايو 2025 ' الإصدار: 2.1 ' ======================================================================= Public Function IsFormPresent(formName As String) As Boolean On Error Resume Next Dim formObj As Object Set formObj = CurrentProject.AllForms(formName) IsFormPresent = Not (formObj Is Nothing) ' طباعة نتيجة التحقق إذا كانت الطباعة مفعلة If DebugPrintEnabled Then Debug.Print "IsFormPresent: التحقق من النموذج '" & formName & "': " & IsFormPresent End If Set formObj = Nothing On Error GoTo 0 End Function ' ======================================================================= ' NavigateForm ' ' وصف: ' دالة عامة للتحكم في فتح وإغلاق نماذج Microsoft Access. تتيح إغلاق ' النموذج الحالي أو نموذج محدد، وفتح نموذج آخر بوضع محدد مع إمكانية ' تمرير بيانات إضافية عبر OpenArgs وتطبيق فلتر عبر WhereCondition. ' إذا كان النموذج المراد فتحه مفتوحًا بالفعل، يتم إغلاقه وإعادة فتحه ' بالوضع المحدد مع الحفاظ على OpenArgs وWhereCondition. ' ' المعاملات: ' - formToClose (اختياري، String): اسم النموذج المراد إغلاقه. ' - formToOpen (اختياري، String): اسم النموذج المراد فتحه. ' - openMode (اختياري، FormOpenMode): وضع فتح النموذج. ' - openArgs (اختياري، Variant): بيانات إضافية لتمريرها إلى النموذج المفتوح. ' - WhereCondition (اختياري، String): شرط فلترة لتحديد السجلات المعروضة. ' ' القيمة المرجعة: ' - Boolean: True إذا نجحت العملية، False إذا حدث خطأ. ' ' أمثلة: ' Call NavigateForm ' إغلاق النموذج الحالي ' Call NavigateForm("Form1") ' إغلاق Form1 ' Call NavigateForm("", "Form2", DialogMode) ' فتح Form2 كحوار ' Call NavigateForm("Form1", "Form2", AddMode) ' إغلاق Form1 وفتح Form2 لإضافة سجل ' Call NavigateForm("", "Form2", NormalMode, "CustomerID=123", "ID=123") ' فتح Form2 مع فلتر ' Call NavigateForm("Form1", "Form2", DialogMode, "Source=MainForm") ' إغلاق Form1 وفتح Form2 كحوار ' Call NavigateForm("", "Form1", DialogMode, , "ID=456") ' إغلاق Form1 وإعادة فتحه كحوار مع فلتر ' ' ملاحظات: ' - تأكد من وجود النماذج المحددة في قاعدة البيانات. ' - وضع DialogMode يوقف تنفيذ الكود حتى إغلاق النموذج. ' - وضع DesignMode قد يكون مقيدًا في قواعد البيانات المحمية. ' - استخدم المتغير العام DebugPrintEnabled لتفعيل طباعة رسائل التصحيح أثناء التجربة. ' - OpenArgs يمكن استخدامه في حدث OnLoad أو OnActivate للنموذج لمعالجة البيانات الممررة. ' - يمكن استدعاء الدالة من ماكرو باستخدام RunCode: NavigateForm() ' - إذا كان النموذج مفتوحًا، سيتم إغلاقه وإعادة فتحه بالوضع المحدد. ' - WhereCondition يتم تطبيقه عند فتح النموذج. ' - يتم منع الاستدعاءات المتكررة بنفس المعاملات فقط إذا كان النموذج مفتوحًا. ' - يتم إعادة تعيين سجل الاستدعاء بعد نجاح أو فشل العملية. ' ' المؤلف: [ابو جودي - منتديات أوفيسنا] ' تاريخ الإنشاء: 24 مايو 2025 ' الإصدار: 2.1 ' ======================================================================= Public Function NavigateForm(Optional ByVal formToClose As String = "", _ Optional ByVal formToOpen As String = "", _ Optional ByVal openMode As FormOpenMode = DefaultMode, _ Optional ByVal openArgs As Variant = Null, _ Optional ByVal WhereCondition As String = "") As Boolean On Error GoTo ErrHandler ' متغير ثابت لتتبع آخر استدعاء Static lastCall As String Dim currentCall As String currentCall = formToClose & "|" & formToOpen & "|" & openMode & "|" & IIf(IsNull(openArgs), "Null", openArgs) & "|" & WhereCondition ' التحقق من التكرار: نتجاهل فقط إذا كان النموذج مفتوحًا ونفس المعاملات If currentCall = lastCall And formToOpen <> "" Then If IsFormPresent(formToOpen) And CurrentProject.AllForms(formToOpen).IsLoaded Then If DebugPrintEnabled Then Debug.Print "NavigateForm: تجاهل استدعاء متكرر بنفس المعاملات: " & currentCall End If NavigateForm = True Exit Function End If End If ' تحديث lastCall lastCall = currentCall ' افتراض النجاح NavigateForm = True ' طباعة المعاملات عند دخول الدالة If DebugPrintEnabled Then Debug.Print "NavigateForm: استدعاء الدالة مع المعاملات - formToClose: '" & formToClose & "', formToOpen: '" & formToOpen & "', openMode: " & openMode & ", openArgs: " & IIf(IsNull(openArgs), "Null", openArgs) & ", WhereCondition: '" & WhereCondition & "'" End If ' إذا لم يتم تمرير أي معاملات، أغلق النموذج الحالي If formToClose = "" And formToOpen = "" Then If Not Screen.ActiveForm Is Nothing Then If DebugPrintEnabled Then Debug.Print "NavigateForm: إغلاق النموذج الحالي '" & Screen.ActiveForm.Name & "'" End If DoCmd.Close acForm, Screen.ActiveForm.Name, acSaveNo ' إعادة تعيين lastCall بعد الإغلاق lastCall = "" Else If DebugPrintEnabled Then Debug.Print "NavigateForm: لا يوجد نموذج حالي مفتوح" End If End If Exit Function End If ' التحقق إذا تم تمرير اسم نموذج للإغلاق If formToClose <> "" Then If IsFormPresent(formToClose) Then If CurrentProject.AllForms(formToClose).IsLoaded Then If DebugPrintEnabled Then Debug.Print "NavigateForm: إغلاق النموذج '" & formToClose & "'" End If DoCmd.Close acForm, formToClose, acSaveNo ' إعادة تعيين lastCall بعد الإغلاق lastCall = "" Else If DebugPrintEnabled Then Debug.Print "NavigateForm: النموذج '" & formToClose & "' غير مفتوح" End If End If Else If DebugPrintEnabled Then Debug.Print "NavigateForm: النموذج '" & formToClose & "' غير موجود" End If MsgBox "النموذج '" & formToClose & "' غير موجود في قاعدة البيانات.", vbExclamation, "خطأ" NavigateForm = False ' إعادة تعيين lastCall بعد الفشل lastCall = "" Exit Function End If End If ' التحقق إذا تم تمرير اسم نموذج للفتح If formToOpen <> "" Then If IsFormPresent(formToOpen) Then ' إذا كان النموذج مفتوحًا بالفعل، أغلقه If CurrentProject.AllForms(formToOpen).IsLoaded Then If DebugPrintEnabled Then Debug.Print "NavigateForm: النموذج '" & formToOpen & "' مفتوح بالفعل، سيتم إغلاقه" End If DoCmd.Close acForm, formToOpen, acSaveNo End If ' فتح النموذج بالوضع المحدد If DebugPrintEnabled Then Debug.Print "NavigateForm: فتح النموذج '" & formToOpen & "' بوضع " & openMode & IIf(IsNull(openArgs), "", ", openArgs: " & openArgs) & IIf(WhereCondition = "", "", ", WhereCondition: " & WhereCondition) End If Select Case openMode Case NormalMode DoCmd.OpenForm formToOpen, acNormal, , WhereCondition, , , openArgs Case DesignMode DoCmd.OpenForm formToOpen, acDesign, , WhereCondition, , , openArgs Case DatasheetMode DoCmd.OpenForm formToOpen, acFormDS, , WhereCondition, , , openArgs Case PreviewMode DoCmd.OpenForm formToOpen, acPreview, , WhereCondition, , , openArgs Case LayoutMode DoCmd.OpenForm formToOpen, acLayout, , WhereCondition, , , openArgs Case AddMode DoCmd.OpenForm formToOpen, acNormal, , WhereCondition, acFormAdd, , openArgs Case EditMode DoCmd.OpenForm formToOpen, acNormal, , WhereCondition, acFormEdit, , openArgs Case ReadOnlyMode DoCmd.OpenForm formToOpen, acNormal, , WhereCondition, acFormReadOnly, , openArgs Case HiddenMode DoCmd.OpenForm formToOpen, acNormal, , WhereCondition, , acHidden, openArgs Case DialogMode DoCmd.OpenForm formToOpen, , , WhereCondition, , acDialog, openArgs Case Else DoCmd.OpenForm formToOpen, , , WhereCondition, , , openArgs End Select ' إعادة تعيين lastCall بعد فتح النموذج lastCall = "" Else If DebugPrintEnabled Then Debug.Print "NavigateForm: النموذج '" & formToOpen & "' غير موجود" End If MsgBox "النموذج '" & formToOpen & "' غير موجود في قاعدة البيانات.", vbExclamation, "خطأ" NavigateForm = False ' إعادة تعيين lastCall بعد الفشل lastCall = "" Exit Function End If End If Exit Function ErrHandler: If DebugPrintEnabled Then Debug.Print "NavigateForm: حدث خطأ: " & Err.Description End If MsgBox "حدث خطأ: " & Err.Description, vbExclamation, "خطأ" NavigateForm = False ' إعادة تعيين lastCall بعد الخطأ lastCall = "" End Function طريقة الاستخدام إنشاء الوحدة النمطية: افتح محرر VBA في (Alt + F11) أنشئ وحدة نمطية جديدة (Insert > Module) انسخ الكود أعلاه والصقه في الوحدة احفظ الوحدة النمطية باسم : basNavigateForm استدعاء الدالة: يمكن استدعاء NavigateForm من أحداث النماذج (مثل OnClick لزر) أو ماكرو أو كود VBA آخر أمثلة الاستدعاء: ' إغلاق النموذج الحالي Call NavigateForm ' إغلاق نموذج محدد Call NavigateForm("Form1") ' فتح نموذج في وضع الحوار Call NavigateForm("", "Form2", DialogMode) ' إغلاق Form1 وفتح Form2 في وضع إضافة سجل Call NavigateForm("Form1", "Form2", AddMode) ' فتح نموذج مع فلتر Call NavigateForm("", "Form2", NormalMode, , "CustomerID=123") ' فتح نموذج مع OpenArgs Call NavigateForm("", "Form2", DialogMode, "Source=MainForm") ' فتح نموذج مخفي Call NavigateForm("", "Form2", HiddenMode) ' فتح نموذج في وضع التصميم Call NavigateForm("", "Form2", DesignMode) ' فتح نموذج في عرض ورقة البيانات Call NavigateForm("", "Form2", DatasheetMode) وأخيـــــرا مرفق بسيط للتجربة NavigateForm (V2.1).accdb