نجوم المشاركات

في بيئات العمل الحديثة التي تعتمد على الشبكات المحلية، يُعد الاتصال المستقر بقاعدة البيانات الخلفية أمرًا أساسيًا لاستمرارية العمليات اليومية. ومع ذلك، تظهر أحيانًا مشكلات تقنية تتعلق بفقدان بيانات الاعتماد (اسم المستخدم وكلمة المرور) الخاصة بالوصول إلى مجلدات شبكية تحتوي على قاعدة البيانات ويتم الاتصال بالشبكات أو الأجهزة عبر البروتوكولات مثل 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

بسيطة ان شاء الله اخي الكريم ، جرب هذا التعديل ، حيث تم استخدام الكود التالي للتحقق والاضافة عندم عدم وجود العام الدراسي الحالي . Private Sub MeetingDate_AfterUpdate() Dim academicYear As String Dim rs As DAO.Recordset Dim response As VbMsgBoxResult Dim prevDate As Variant On Error GoTo ErrHandler academicYear = IIf(Month(Me.MeetingDate) >= 9, _ Year(Me.MeetingDate) & "-" & (Year(Me.MeetingDate) + 1), _ (Year(Me.MeetingDate) - 1) & "-" & Year(Me.MeetingDate)) Set rs = CurrentDb.OpenRecordset("SELECT Academic_Name FROM AcademicYearTble WHERE Academic_Name = '" & academicYear & "'", dbOpenSnapshot) If rs.EOF Then response = MsgBox("العام الدراسي """ & academicYear & """ غير موجود." & vbCrLf & "هل تريد إضافته؟", vbQuestion + vbYesNo + vbMsgBoxRight, "إضافة عام دراسي") If response = vbYes Then CurrentDb.Execute "INSERT INTO AcademicYearTble (Academic_Name) VALUES ('" & academicYear & "')", dbFailOnError Me.Academic_Name = academicYear Else MsgBox "تم إلغاء التحديث.", vbExclamation Me.Undo End If Else Me.Academic_Name = academicYear End If rs.Close Set rs = Nothing Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight, "" On Error Resume Next rs.Close Set rs = Nothing End Sub الملف بعد التعديل AcademicYear2.accdb

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته 🙂 درسنا اليوم عبارة عن فكرة تجميلية لقاعدة البيانات وإظهار شاشة إنتظار عند الإنتقال بين النماذج.. فكرة لمعت وحبيت أوثقها قبل أن تطير بلا عودة 😅 متابعة ممتعة 🙂 حمل المثال من المرفقات .. Waiting Screen.accdb

روعة الروعة ما شاء الله انا استفدت منه واستاذنكم اخده في شغلي لو مفيش مانع وجزاكم الله كل خير يارب

بارك الله فيكم روعة انا أستأذنكم اخده في مشروعي استعمله لو مفيش مانع عشان ده مش مجهودي ده مجهود غيري لو امكن ولو لم يمكن خلاص وجزى الله كل من عمله خير عن أمه الإسلام وعن كل من أستفاد به

عاشت ايدك أستاذ ممنون منك و جزاك الله كل خير وفتح عليك

فنان وبيعمل حاجات بتوع فنانين ربنا يديك العافية على الحركات الجميلة والأفكار الإبداعية .. قد أكون مش ملم بالموضوع دا فنيا وتقنيا لأني ماليش في الشبكات كثير !! .. 😅 بس هل زي مانا فهمت أنه يتم تخزين بيانات الاعتماد من خلال النموذج التالي ؟ .. يعني مش بيقراها الكود تلقائيا من إعدادات الويندوز ؟ أوعك تتريق عليه 👊

نعم استاذي الفاضل .... هذا هو النظام المتبع لبرامج الكاشير حيث تتم الفاتورة على مرحلتين : 1 - فتح الفاتورة واجراء الاضافات والتعديلات عليها - ومن ثم عرض الفاتورة المفتوحة باي وقت 2 - تسكير الفاتورة ورفعها من قائمة الفواتير المفتوحة لذا ... يرجى التكرم من حضرتك اذا سمح وقتكم المبارك باعطاء مثال لذلك ... كل الشكر والتقدير استاذنا الفاضل 🌹 ....

أخي @algammal ربما ما لم تلاحظه هو أن القيم تعبأ على عناصر الكومبوبوكس مع تجاهل الفراغات والتكرارات ولهذا السبب تظهر معك مرة واحدة فقط وذلك لأن أرقام التسلسل الموجودة على ورقة معاشات هي نفسها الموجودة على الـ DATA ما يهمنا هنا هو جلب جميع البيانات المتوفرة على الورقتين التي تتضمن شروط التصفية المختارة وهذا واضح من خلال الإحصائيات أسفله وللتوضيح أكثر دعنا نجرب إضافة تسلسل جديد على ورقة المعاشات غير موجود مسبقا في DATA ونرى كيف سيتم التعامل معه لاحظ معي عند اختيار رقم التسلسل 1 الاحصائيات لدينا تظهر عدد الموظفين 2 على ورقة معاشات 1 وورقة DATA 1 أرفق لك آخر تحديث للملف توحيد البحث في شيت واحد v6.xlsb

وعليكم السلام ورحمة الله وبركاته ،، مشاركة معنوية مع الأساتذة والمعلمين ، وكفكرة أستاذنا @kkhalifa1960 ، هي جميلة وتجهلك تتنقل بين الفواتير التي تريدها ، وتستطيع التعديل عليها كتحسين ( لا ينقص من جمالها شيء طبعاً ) بحيث يتم تعليم الفواتير التي تم دفعها بحقل Yes/No = Yes للفواتير المدفوعة ، وهنا سيتم عرض الفواتير التي لها قيمة = No . وطبعاً في زر الدفع سيتم اضافة استعلام لتحديث قيمة هذا الحقل = Yes مع Requery للقائمة المنسدلة . أو أن التنفيذ الذي يحاول أخونا الكريم الوصول اليه هو ما يشبه نظام الطاولات في مطعم على سبيل المثال ، على اعتبار ان الطاولات هي فواتير مفتوحة ولكل فاتورة رقم تم حجزه ويحتوي بيانات ، ويتنقل بينها كيف ما يشاء وإنهاء ما يشاء حسب الإنتهاء منهم .

بعد اذن اخي واستاذي خليفة اولا : النموذج المفتوح لا يمكنك فتحه مرة أخرى . ثانيا : بطريقتك هذه التي هي ربط النماذج بالجداول او الاستعلامات مباشرة .. لا يمكنك تحقيق فكرتك بطريقة علمية احترافية صحيحة وحتى لا اخيب آمالك يمكنك عمل نماذج عدة طبق الأصل والعمل عليها في وقت واحد بشروط : 1- ان تكون النماذج غير منضمة الى اي مصدر بيانات 2- ادخال البيانات وحفظها باستخدام مجموعة السجلات Dao

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

جزاك الله خيرا علي المجهود الرائع

ConvertDates.rar

ولتجنب استخدام جملة On Error Resume Next يمكن تعديل الكود بهذا الشكل Sub Test2() Dim ws As Worksheet Application.ScreenUpdating = False For Each ws In ThisWorkbook.Worksheets With ws If .AutoFilterMode Then .AutoFilterMode = False If .FilterMode = True Then .ShowAllData End If End With Next ws Application.ScreenUpdating = True End Sub

https://www.gulf-up.com/oddf49qg3u7f/SCAN.rar

ان شاء الله جيد

بحب اضافة ما يلي على الأكواد الملف من جديد Jadid_YARA_2User Uniqus..xlsm

مرفق طريقة اخرى بعد اذن الأساتذة الكرم Date.xlsx

وعليكم السلام-فقط عليك استخدام هذه المعادلة لتاريخ البداية =DATE(C3,B3,A3) وهذه لتاريخ النهاية =DATE(F3,E3,D3) Date1.xlsx

تحية طيبة للجميع وأسأل الله أن يديم عليكم لباس الصحة والعافية عندي كودين الأول لترحيل حلقة متكررة إلى شيت 2 وحفظ الشيت الثاني PDF والكود الثاني من تعديل الأستاذ (الرائد77) عند دمج الكودين يطلع لي خطأ في السطر sned بمعنى أن الترحيل إلى PDF يعمل تمام ولكن المشكلة ما قدرت أرسله على الإيميل الخطأ عند send المطلوب : 1) تصحيح خطأ الإرسال بالإيميل 2) وإذا كان من الممكن استبدال سطر a = 1 Do While a <= 4 بهذا السطر لكي استغني عن تعديل الكود في كل مرة For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row الكود بالكامل Sub Send_Payslip() Dim OutApp As Object Dim OutMail As Object a = 1 Do While a <= 4 EmpID = Sheet2.Range("A8").Offset(a, 0).Value Sheet3.Range("A8").Value = EmpID Filename = Sheet3.Range("A1").Value & ".pdf" Sheet3.ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\" & Filename Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With OutMail .To = Range("A22").Value .Subject = Range("A1").Value .HTMLBody = Range("A1").Value .Attachments.Add (ThisWorkbook.Path & "\" & Sheet3.Range("A1").Value & ".pdf") .Send End With Set OutMail = Nothing Set OutApp = Nothing a = a + 1 Loop End Sub تحياتي للجميع إرسال إيملات pDF.xlsm

بالنسبة لمشكلة الإرسال فيبدو ان الإرسال يتم قبل أن يتم تصدير الملف pdf لذلك يمكنك استعمال أمر الانتظار قبل تنفيذ الكود الثاني لبعض الثواني باستعمال الأمر wait هكذا Application.Wait DateAdd("s", 5, Now) وبالنسبة لاستبدال while فلا مشكلة لم يستعمل المتغير a في الكود ضع سطر for بدلا من while وضع سطر next بدلا من زيادة المتغير a وبعده loop بالتوفيق

اخي جرب المرفق 1.xlsm

تفضل لعله المطلوب عدم تكرار.rar

السلام عليكم أخي أبو البراء الغالي: الله يسعد جميع أوقاتك صباحها ومساءها...بنور الإيمان

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

أخي الفاضل ياسين أبو وسام كان من المفترض طبقاً للتوجيهات إرفاق الملف الخاص بالكود عموماً أنا كنت قد جهزت الملف بالفعل ، وفي انتظار موضوعك الجديد (اعذرني للتقيد بالتوجيهات) إليك الكود بعد تعديلات جوهرية فيه ليتناسب مع طلبك الجديد Sub TransferData() Dim WS As Worksheet, SH As Worksheet Dim X As Long, I As Long, Arr Set WS = Sheets("ترحيل"): Set SH = Sheets("MP LIST") X = SH.Cells(Rows.Count, 2).End(3).Row + 1 Application.ScreenUpdating = False If Not SH.Range("B:B").Find(WS.Range("G9"), , , xlWhole, , False) Is Nothing Then MsgBox "تم إدراج رقم الموظف من قبل", vbInformation: Exit Sub Else Arr = Array("G9", "G10", "G11", "G14", "G15", "G16", "G17", "G18", "G19", "G20", "G22", "G24", "G25", "G26", "G27", "G28", _ "I28", "G30", "", "", "", "G32", "", "", "", "G13", "I13", "G44", "H44", "I44", "G47", "H47", "I47", "", "G34", _ "G35", "G36", "G37", "G38", "G39", "G40", "J41", "G49") For I = LBound(Arr) To UBound(Arr) If Arr(I) <> "" Then Arr(I) = WS.Range(Arr(I)).Value If IsEmpty(Arr(I)) Then MsgBox "البيانات غير كاملة يرجى إكمال كافة الحقول": Exit Sub Next I With SH .Cells(X, 1) = .Cells(X, 1).Row - 2 .Cells(X, 2).Resize(, UBound(Arr) + 1) = Arr End With 'WS.Range("G9:J11,G13:H13,I13:J13,G14:J20,G22:J22,G24:J27,G28:J28,G30:J30,G32:J32,G34:J40,G44:J44,G47:J47,G49:J49").ClearContents MsgBox "تم الترحيل بنجاح", vbInformation End If Application.ScreenUpdating = True End Sub أرجو أن يكون المطلوب بالنسبة لهذا السطر 'WS.Range("G9:J11,G13:H13,I13:J13,G14:J20,G22:J22,G24:J27,G28:J28,G30:J30,G32:J32,G34:J40,G44:J44,G47:J47,G49:J49").ClearContents خاص بمسح البيانات بعد الترحيل ..تم وضع تعليق لإلغاء تنفيذه لتجربة الكود قم بتغيير رقم الموظف لتجربة الكود .. تقبل تحياتي Transfer Data Using Arrays YasserKhalil.rar

اذن اخي من الاحسن ان تستعمل هذ الكود الذي طرحته في مشاركة سابقة Private Sub Worksheet_Selectionchange(ByVal Target As Range) If Target.HasFormula = True Then ActiveCell.Offset(0, 1).Select ElseIf Target.MergeCells = True And Target.HasFormula = True Then Target.Offset(0, 1).Select ElseIf ActiveCell.HasFormula = True And ActiveCell.MergeCells = True Then ActiveCell.Offset(0, 1).Select End If End Sub

السلام عليكم تفضل اخ khhanna اعداد تقارير مدرسية.zip

السلام عليكم ورحمة الله تقبل الله منا ومنكم الصلاة والصيام والقيام وصالح الأعمال... أخي الكريم، أستأذن من أخي الكريم والحبيب عبدالله في تغيير طفيف على أحد أكواده في الملف حسب طلبك ... أرجو أني وفقت في ذلك وإن لم يكن كذلك فأرجو من أخي عبدالله التدخل لعمل المطلوب... أخوكم بن علية اعداد تقارير مدرسية.rar