البحث في الموقع

السلام عليكم ورحمة الله تعالى وبركاته سوف اقدم لكم اليوم ان شاء الله تعالى فكرة أتمتة عمليات البيع بكل الطرق (FIFO , LIFO , HighestPrice , LatestPrice) ولكن أولا مقدمه بشكل نظرى عن هذه العبارة لتوضيح هذه المصطلحات هى تعنى أن النظام أو البرنامج يقوم بشكل آلي (تلقائي) باختيار الكمية المناسبة من المخزون عند تنفيذ عملية البيع، بناءً على طريقة معينة وذلك لتحديد أي دفعة (Batch) من المخزون سيتم السحب منها. هذه الطرق هي ما تُعرف بـ "سياسات تقييم المخزون أو صرف المخزون"، وشرحها كالتالي: FIFO (First In, First Out - الوارد أولاً يصرف أولاً) تعني أن النظام سيبدأ في بيع الكميات من أول دفعة تم شراؤها أو إدخالها للمخزون تخصم الكميات التي تُباع أولاً من أول دفعة تم شرائها. تستخدم غالبًا في المنتجات القابلة للتلف (مثل الطعام أو الدواء). مثال: اشتريت 100 وحدة بـ10 جنيه، ثم 100 وحدة بـ12 جنيه. عند بيع 50 وحدة، سيتم بيعهم من الدفعة الأولى (10 جنيه). LIFO (Last In, First Out - الوارد أخيراً يصرف أولاً) تعني أن النظام سيبدأ في بيع الكميات من آخر دفعة تم شراؤها تخصم الكميات التي تُباع أولاً من آخر دفعة تم شرائها. تُستخدم في بعض الأنظمة المحاسبية عند توقع ارتفاع الأسعار. مثال: نفس المثال السابق. عند بيع 50 وحدة، سيتم بيعهم من الدفعة الثانية (12 جنيه). HighestPrice (أعلى سعر أولاً) يعني أن النظام سيبدأ في بيع الكميات من الدُفَع ذات السعر الأعلى تخصم الكميات التي تُباع أولاً من الدفع ذات السعر الأعلى. مفيد في حالات تحسين الربحية أو تقليل الخسائر تُستخدم في حالات معينة عند الرغبة في التخلص من البضاعة ذات التكلفة الأعلى لتقليل الخسائر أو تقليل التكاليف المخزنية المرتفعة. مثال: عندك 3 دفعات بأسعار 10، 12، 15. النظام يبدأ البيع من الدفعة بسعر 15. LatestPrice (أحدث دفعة أولاً) المقصود هنا بيع الكمية من أحدث تاريخ شراء تخصم الكميات التي تُباع أولاً من الدفع ذات تاريخ الشراء الأحدث. يختلف عن LIFO بإنه يعتمد على تاريخ الشراء وليس ترتيب الإدخال. مفيد عندما تكون تواريخ الشراء غير مرتبة أو النظام يسمح بإدخال متأخر. التطبيق يعتمد على التالى جدول يحتوي على إعدادات طريقة البيع : tblSalesSettings المفروض الجدول يحتوى على سجل واحد فقط ويتم تحديد طريقة البيع حسب الرغبة او حسب النظام المحاسبى المتبع جدول المنتجات : tblProducts - يحتوي على بيانات المنتجات الأساسية. جدول الواردات : tblPurchaseBatches - يتبع كل دفعة شراء لمنتج معين. جدول لتسجيل عمليات الارتجاع : tblReturns - يتبع كل عمليات الإرتجاع بعد إتمام عملية شراء لمنتج معين. جدول تفاصيل كميات المبيعات حسب الدفعات : tblSaleBatchDetails- يتبع كل دفعة بيع لمنتج معين حسب الكمية وتبعا لمعرف الدغعات. جدول تفاصيل المبيعات : tblSaleDetails - يتبع كل المنتجات التى يتم بيعها داخل الفاتورة. جدول المبيعات : tblSales - يحتوي على إجمالي كل فاتورة. وأخيرا المرفق للتجربــــــــــــة ملاحظة لم أهتم بأى تفاصيل لا للحذف أو للارتجاع لانها لن يكون لها أى تأثير يذكر لأن الكميات يتم حسابها بناء على معرف الدفعات بشكل ديناميكى حسب المبيعات و بناء على الواردات للدفعات ما تم الاهتمام به فقط هو التعامل مع طرق البيع المختلفة لاصدار الفواتير او صرف الكميات حسب الطرق المحاسبية بشكل صحيح ومرن وبناء عليه حصر الكميات المتبقية يعنى ببساطه بيع وجرد فى نفس الوقت على اساس محاسبى صحيح بمرونة وفاعليه نسيت توضيح شئ مهم : مثلا يوجد وارد لمنتج بأكثر من دفعه ولكل دفعه سعر بيع وسعر شراء طيب لنفترض ان الدفعه 1 للمنتج 101 عدد الكميات لها 5 الدفعه 2 للمنتج 101 عدد الكميات لها 10 اذا اجمال الكميات هو 15 طيب عند اصدار الفاتورة مع الاختيار : FIFO من جدول اعدادت طرق البيع لنفترض اننا نريد بيع 8 قطع من ها المنتج فى هذه الحاله يتم عمل التالى صرف 5 من الدفعه 1 وصرف 3 من الدفعه 2 طيب سعر بيع الدفعه الاولى لو 120 وسعر بيع الدفعه الثانيه 130 يكون ( 5*120 ) + ( 3 * 130 ) = 600 + 390 = يكون الناتج 990 وفى هذه الحاله لا يتم كتابة سعر للوحده فى الفاتورة بل يتم حساب المتوسط أتمتة عمليات البيع بكل الطرق .accdb

السلام عليكم ورحمة الله وبركاته.. كنت قد طرحت سابقًا موضوع يتكلم عن ارسال رسائل الى الواتس اب لعدد X من المستخدمين من خلال الاكسس وهنا X معناها عدد معين كأن يكون 10 مستخدمين او اكثر او اقل.. الموضوع القديم كان فيه مشكلة وهو ان رسائل الواتس اب الطويلة لا يمكن ارسال او تُرسل بشكل مقطوع! الحمدلله في هذا الاصدار تم التغلب نهائيًا على هذه المشكلة واصبح البرنامج يرسل عدد كلمات بالعدد الذي يسمح به الواتس اب الجديد في هذا الاصدار: امكانية ارسال المرفقات ( الصور فقط ) 1- يمكنك ارسال رسائل فقط 2- يمكنك ارسال صور فقط 3- يمكنك ارسال رسالة مع صورة صورة مشروع الاكسس: قم بتحديد الاشخاص الذين تريد ارسال الرسالة لهم مع وضع نص الرسالة مع امكانية تحديد الكل يمكنك شروط البرنامج بحسب ماتراه مناسباً. النتيجة: ملاحظة يجب ان يكون برنامج الواتس اب موجود في جهاز الكومبيوتر واهم ملاحظة هي يجب كتاب رقم الواتس اب الذي تريد ان ترسل له الرسالة كما يظهر في البرنامج، مثال: لتحميل الواتس اب من الرابط الاتي: https://www.whatsapp.com/download بالمناسبة: الحمدلله انتهيت من برنامج تحويل الصور الى نصوص مهما كانت اللغة ( OCR ) وخصوصا اللغة العربية وحتى الصور التي تكون مكتوبة بخط اليد يتم تحويلها الى نصوص يسهل التعديل عليها في برنامج الوورد البرنامج يعمل بطريقتين: 1- يمكنك تحويل الصور بشكل مباشر 2- يمكنك استخدام الاكسس في ارسال CommandLine يتضمن مسار الصورة ومسار ملف التكست للنص الذي سوف يحفظ وسيقوم البرنامج بعمله لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. SendWhatsAppMessages.rar

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

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

بسم الله الرحمن الرحيم.. السلام عليكم ورحمة الله وبركاته.. بعد طول غياب عن الساحة بسبب ضروف الحياة والعمل.. اقدم لكم اداة صغيرة من برمجتي بلغة Visual Studio .NET تقوم بالتقاط الصور كاميرا الويب او اي كاميرا متصلة بالكومبيوتر ومن ثم خزنها في الجهاز الاداة قمت بربطها مع الاكسس، بحيث تقوم بتمرير براميتر من الاكسس الى الاداة وهذا البراميتر متمثل بـ مسار حفظ الصورة + واسم الصورة + صيغتها مثال: Dim SavedPath As String SavedPath = """" & CurrentProject.Path & "\Capture.png" & """" الاداة تستخدم مكتبات AForge للتحكم بالكاميرات. صورة الاداة: بمجرد ان تضغط زر Open Camera من الاكسس ستعمل الاداة مباشرة قم بترتيب الكاميرا الخاصة بك لاخذ لقطة مناسبة واضغط على الزر Snapshot ثم اضغط على الز save لحفظ الصورة. الاداة اخذت مني وقت 8 ساعات في البرمجة لذلك لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. SEMO_webCam.rar كلمات مفتاحية: التقاط صورة من الكاميرا، حفظ الصورة من الكاميرا، جلب الصورة من كاميرا الويب، جلب الصورة من الكاميرا وحفظها في قاعدة البيانات، حفظ الصور بقاعدة البيانات، خزن الصورة من الكاميرا كاميرا ويب قاعدة بيانات اكسس، اكسس كاميرا الويب، اكسس كاميرا، جلب الصورة من الكاميرا

السلام عليكم, في سنة 2017 قمت بكتابة كلاس بسيط لحماية برنامجي ولضمان برنامجي لا يعمل في غير كومبيوترات في حاله بيعه. مميزات الكلاس: 1- قفل قاعدة البيانات على ( رقم الهارد , البروسيسور , المذربورد , الماك أدريس ) 2- (استحاله) فك النماذج والتقارير في حال عدم تجاوزك لنموذج ( تسجيل الدخول ) ببساطة ستقول يمكنني العثور على باسورد القاعدة داخل الجدول ( الطريقة المعتادة لدينا جميعا في انشاء نموذج تسجيل دخول ). قبل كل شي ليكن لدينا مثلا جدول اسمة ( tbl_Login ) و نموذج اسمه ( frm_Login ) الجدول لتخزين اسم المستخدم وكلمة المرور والنموذج لعمل تسجيل الدخول عند ذهابنا للجدول ( tbl_Login ) ، سوف نحصل على باسورد مشفر من الجدول لو كان الباسورد مثلا ( 313 ) فإنك ستحصل على ( 701D6068 ) 2- عندما نقوم بتسجيل الدخول في النموذج سيقوم البرنامج بأخذ كلمة السر المدخلة ويقوم بتشفيرها ثم يقوم بمطابقتها مع الباسورد الموجود في الجدول اذا كان الباسورد المُدخل يطابق الجدول سيكتب قيمة معينة runtime ويقوم بازالة جميع القيود من النماذج والتقارير. اولا: كلاس الحماية Option Compare Database '----------------------------------------------------- ' Protection Module Coded By Hassanein Hirz Aldeen (SEMO.Pa3x) ' Date 26/11/2017 ' All rights reserved. copyright © 2017 '----------------------------------------------------- Public SEMO As String Function SEMO_GET() SEMO = SEMO SEMO_GET = SEMO End Function Function PR() As Boolean PR = False 'False=Disabled , True=Enabled End Function Function HWND_ID() HWND_ID = "3C3F4825" 'Your HWID End Function Function HWND_MSG() HWND_MSG = "...ليست لديك صلاحيات كافية لإستخدام هذا الاجراء" End Function Function KEY_ENDE() KEY_ENDE = "PA$X" End Function Function HWND_GET() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_GET = disk.volumeserialnumber Exit For End If Next End Function Function HWND_PROTECTION() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_PROTECTION = disk.volumeserialnumber Exit For End If Next If HWND_ID = HWND_PROTECTION Then HWND_PROTECTION = "True" Else HWND_PROTECTION = "False" End If End Function 'Code contained within module named mdlforencryptionanddecryption Public Function XORDecryption(CodeKey As String, DataIn As String) As String Dim arkdata1 As Long Dim strDataOut As String Dim intXOrValue1 As Integer Dim intXOrValue2 As Integer For arkdata1 = 1 To (Len(DataIn) / 2) 'The first value to be XOr-ed comes from the data to be encrypted intXOrValue1 = Val("&H" & (Mid(DataIn, (2 * arkdata1) - 1, 2))) 'The second value comes from the code key intXOrValue2 = Asc(Mid(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1)) strDataOut = strDataOut + Chr(intXOrValue1 Xor intXOrValue2) Next arkdata1 XORDecryption = strDataOut End Function Public Function XOREncryption(CodeKey As String, DataIn As String) As String Dim arkdata1 As Long Dim strDataOut As String Dim temp As Integer Dim tempstring As String Dim intXOrValue1 As Integer Dim intXOrValue2 As Integer For arkdata1 = 1 To Len(DataIn) 'The first value to be XOr-ed comes from the data to be encrypted intXOrValue1 = Asc(Mid$(DataIn, arkdata1, 1)) 'The second value comes from the code key intXOrValue2 = Asc(Mid$(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1)) temp = (intXOrValue1 Xor intXOrValue2) tempstring = Hex(temp) If Len(tempstring) = 1 Then tempstring = "0" & tempstring strDataOut = strDataOut + tempstring Next arkdata1 XOREncryption = strDataOut End Function الاستخدام لكل النماذج والتقارير اكتب في حدث Form_Load Option Compare Database Private Sub Form_Load() On Error Resume Next If HWND_PROTECTION = "False" Then MsgBox HWND_MSG, vbCritical, "عملية خاطئة" For i = 0 To Controls.Count - 1 Dim X As Control Set X = Me.Controls.Item(i) X.Visible = False Next DoCmd.Close DoCmd.CloseDatabase DoCmd.Quit End If If Protection.SEMO_GET = "SEMO" = False Then MsgBox HWND_MSG, vbCritical, "عملية خاطئة" For i = 0 To Controls.Count - 1 Dim XS As Control Set XS = Me.Controls.Item(i) XS.Visible = False Next DoCmd.Close DoCmd.CloseDatabase DoCmd.Quit End If End Sub الان عندما تريد اعطاء القاعدة لشخص ما قم باعطاءه اولا ملف الـ VBS هذا '----------------------------------------------------- ' ReCoded By Hassanein Hirz Aldeen (SEMO.Pa3x) ' Date 26/11/2017 ' All rights reserved. copyright © 2017 '----------------------------------------------------- ' Get clipboard text Set objHTML = CreateObject("htmlfile") Set Ws = CreateObject("WScript.Shell") Clipboardtext = objHTML.ParentWindow.ClipboardData.GetData("text") sText = HWND_GET 'Set Clipboard Ws.Run "mshta.exe ""javascript:clipboardData.setData('text','" & Replace(Replace(sText, "\", "\\"), "'", "\'") & "');close();""", 0, True MsgBox "Copied!" Function HWND_GET() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_GET = disk.volumeserialnumber Exit For End If Next End Function وظيفة هذا الملف يقوم باستخراج ( رقم الهارد , البروسيسور , المذربورد , الماك أدريس ) ثم ينسخه بعدما يشغله سيقوم العميل باعطاءك هذا الرقم لكي تقوم انت بدورك بوضعه داخل الكلاس في المنطقة Function HWND_ID() HWND_ID = "Your HWID" End Function استبدل كلمة ( Your HWID ) بالرقم الذي سيعطيه لك العميل. ثم بعد ذلك قم بحفظ القاعدة بصيغة ( ACCDE ) واتحدا اي شخص يفتحها مرة اخرى: لكي تفتح النماذج والتقارير عليك بتخطي نموذج تسجيل الدخول ارفقت لكم قاعدة محمية وقاعدة بدون حماية مع ملف الـ VBS الذي يستخرج ارقام قطع الجهاز ويقوم بنسخها،، اتمنى لكم الفائدة جميعاً اهداء الموضوع الى مُعلمي الرائع @jjafferr حسنين Login_SEMO_Pa3x.rar

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته.. اقدم لكم اداة من برمجتي المتواضعة لتحويل اكواد الـ SQL الى VBA قبل كل شي، الاداة حصراً للمبرمجين الذين يستخدمون الكود في الادراج والتعديل والحذف وليس للأشخاص الذين يستخدمون الواجهة الرسومية للأكسس الخالية من الكود ماهي فائدة الأداة ولماذا استخدمها؟ حسناً، لو كان لدينا جدول اسمة tbl_movementes يقوم بتسجيل جميع الحركات التي تحدث ( اضافة , تعديل , حذف ) وهذا الجدول احتاجه في كثير من النماذج، فهل من المعقول ان اقوم بكتابة عبارة INSERT INTO في كل نموذج ؟ اكيد لا، سأقوم بكتابة Sub واقوم بإستدعاءه كل مرة اريد ان اضيف بها بيانات الى الجدول واختصاراً للوقت الطويل والأخطاء التي ربما ستحدث اثناء عملية التحويل، قمت بكتابة اداة تقوم بهذا الغرض الاداة وضيفتها فقط ( Insert , Update ) صورة الاداة: لنطبق على عملية اضافة بيانات جديد: 1- قم بفتح 2- ثم قم بأختيار الجدول الذي تريده، وقم بإدراج جميع الحقول، كما في الصورة 3- من النافذة العليا اختر النافذة تصميم وقم بتعديل نوع الاستعلام الى استعلام إلحاق وثم بإختيار نفس الجدول لكي يقوم بألحاق البيانات به. الآن لنرى النتيجة 3- الان قم بعرض اكواد الـ SQL 4- قم بنسخ جميع الاكواد كما في الصورة الاتية 5- الان قم بفتح الاداة، واختر النوع Insert، ثم الصق اكواد الـ SQL في مربع النص SQL 6- قبل عملية التحويل قم بإلغاء الأعمدة التي لا ترغب بها من القائمة على اليمين ( Column Remove ) مثلا سأقوم بألغاء العمود IsDeleted وذلك بالضغط على اسم العمود رسالة تخبرك بتأكيد عملية حذف العمود 7- اضغط على الزر Convert 8- تم تحويل الكود ونسخه، الان قم بلصقه في الأكسس واستخدمه الاستخدام النتيجة، تم ادراج البيانات بالجدول لنطبق على عملية تعديل البيانات: نفس الخطوات القديمة فقط من الاداة اختر نوع الاستعلام Update من المعروف ان عملية تعديل البيانات تتطلب معيار للتعديل WHERE COLUMN NAME = Number لذلك عندما نقوم بإنشاء الاستعلام نقوم بوضع عمود المعيار اخر عمود في الاستعلام هكذا من لديه ملاحظات أو اضافات تعطى للبرمج حصراً أحرم تعديل البرنامج بأحد ادوات الهندسة العكسية او نسبه لأي شخص تمت البرمجة حصرياً لمنتدى أوفسينا، اهداء الى معلمي العزيز @jjafferr تحياتي للجميع. SQL-VBA.rar

الأخوة الكرام.. 🌹 السلام عليكم ورحمة الله وبركاته.. هل يمكنكم التكرم بمساعدتي في تفعيل نموذج البحث في الملف المرفق اريد نموذج البحث أن يقوم بفلترة البيانات في نموذج البحث بناءا على ثلاثة معايير بمجرد الكتابة تبدأ الفلترة.. أي يتم فلترة الجدول بالمعيار الأول ومن ثم فلترة البيانات المفلترة مرة أخرى بناءا على المعيار الثاني في الصندوق النصي 2 ومن ثم الفلترة الاضافية بناءا على المعيار الثالث. كذلك تفعيل امكانية طباعة النتائج أي البيانات المفلترة عند الصغط على زر الطباعة من خلال عرض نافذة الطباعة وليس الطباعة مباشرة. أنا أسف لو كان طلبي كبيرا او صعبا ☺️ ولكني اتمنى من الله ان يسخر لي من يساعدني في هذا المنتدى الرائع ولكم مني خالص الشكر 🖐️ قاعدة البيانات مع محرك البحث-1.accdb

السلام عليكم ورحمة الله وبركاته اخواتي فى الله احتاج مساعده لحل مشكلة اللغة العربية في msgbox التى لا تظهر باللغة العربية علي شاشة المستخدم في اكسس

شاهد الشرح ولو محتاج نسخه تجريبية كلمني واتساب https://wa.me/+201068694941?text=محتاج_نسخه_تجريبية او تليجرام https://t.me/Programming472

السلام عليكم ورحمة الله وبركاته.. من المعروف ان الواتس اب يسمح لك بارسال 5 رسائل فقط في كل مرة يعني لو كان لدينا 15 شخص نريد ان نرسل له رسالة علينا ان نقوم باعادة توجيه الرسالة 3 مرات كل مرة 5 اشخاص.. قمت بعمل اداة صغيرة في الـ NET. لتقوم بهذه المهمة. صورة مشروع الاكسس: قم بتحديد الاشخاص الذين تريد ارسال الرسالة لهم مع وضع نص الرسالة مع امكانية تحديد الكل يمكنك شروط البرنامج بحسب ماتراه مناسباً. النتيجة: ملاحظة يجب ان يكون برنامج الواتس اب موجود في جهاز الكومبيوتر واهم ملاحظة هي يجب كتاب رقم الواتس اب الذي تريد ان ترسل له الرسالة كما يظهر في البرنامج، مثال: لتحميل الواتس اب من الرابط الاتي: https://www.whatsapp.com/download لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. Whatsapp-Message-Sender.rar

السلام عليكم ورحمة الله وبركاته.. اقدم لكم اداة صغيرة من برمجتي وضيفتها تغيير اسم الدولة/المنطقة التي تعتمد عليها الكثير من البرامج خصوصاً العربية التي تعتمد الـ Unicode الأداة مكتوب بلغة Visual Studio .NET مبدأ عملها يحتاج ان تقوم بتمرير براميتر لها يحتوي على كود الدولة. عموما كتبت لكم مثال في الاكسس سورس الأداة: Imports System.Runtime.InteropServices Imports System.Threading Imports Microsoft.Win32 Imports System.Globalization Module Main 'C0ded bY: SEMO.Pa3x (: 'Date: 27-5-2021 : 03:26 PM Const subkey As String = "SYSTEM\CurrentControlSet\Control\Nls\Language\" Dim CodeArray As String() = {"af-ZA", "ar-AE", "ar-BH", "ar-DZ", "ar-EG", "ar-IQ", "ar-JO", "ar-KW", "ar-LB", "ar-LY", "ar-MA", "ar-OM", "ar-QA", "ar-SA", "ar-SY", "ar-TN", "ar-YE", "az-AZ", "az-AZ", "be-BY", "bg-BG", "bs-BA", "ca-ES", "cs-CZ", "cy-GB", "da-DK", "de-AT", "de-CH", "de-DE", "de-LI", "de-LU", "dv-MV", "el-GR", "en-AU", "en-BZ", "en-CA", "en-CB", "en-GB", "en-IE", "en-JM", "en-NZ", "en-PH", "en-TT", "en-US", "en-ZA", "en-ZW", "es-AR", "es-BO", "es-CL", "es-CO", "es-CR", "es-DO", "es-EC", "es-ES", "es-ES", "es-GT", "es-HN", "es-MX", "es-NI", "es-PA", "es-PE", "es-PR", "es-PY", "es-SV", "es-UY", "es-VE", "et-EE", "eu-ES", "fa-IR", "fi-FI", "fo-FO", "fr-BE", "fr-CA", "fr-CH", "fr-FR", "fr-LU", "fr-MC", "gl-ES", "gu-IN", "he-IL", "hi-IN", "hr-BA", "hr-HR", "hu-HU", "hy-AM", "id-ID", "is-IS", "it-CH", "it-IT", "ja-JP", "ka-GE", "kk-KZ", "kn-IN", "ko-KR", "kok-IN", "ky-KG", "lt-LT", "lv-LV", "mi-NZ", "mk-MK", "mn-MN", "mr-IN", "ms-BN", "ms-MY", "mt-MT", "nb-NO", "nl-BE", "nl-NL", "nn-NO", "ns-ZA", "pa-IN", "pl-PL", "ps-AR", "pt-BR", "pt-PT", "qu-BO", "qu-EC", "qu-PE", "ro-RO", "ru-RU", "sa-IN", "se-FI", "se-FI", "se-FI", "se-NO", "se-NO", "se-NO", "se-SE", "se-SE", "se-SE", "sk-SK", "sl-SI", "sq-AL", "sr-BA", "sr-BA", "sr-SP", "sr-SP", "sv-FI", "sv-SE", "sw-KE", "syr-SY", "ta-IN", "te-IN", "th-TH", "tl-PH", "tn-ZA", "tr-TR", "tt-RU", "uk-UA", "ur-PK", "uz-UZ", "uz-UZ", "vi-VN", "xh-ZA", "zh-CN", "zh-HK", "zh-MO", "zh-SG", "zh-TW", "zu-ZA"} Sub main() For Each arg As String In My.Application.CommandLineArgs 'check if arg exist in array ! Dim index As Integer = Array.IndexOf(CodeArray, arg) If index > 0 Then 'do change (: SetSystemNonUnicodeLanguage(CultureInfo.GetCultureInfo(arg)) End If Next End Sub Private Sub SetSystemNonUnicodeLanguage(ByVal cinfo As CultureInfo) Dim regkey = Registry.LocalMachine.OpenSubKey(subkey, True) regkey.SetValue("Default", cinfo.LCID.ToString("x4")) ' Reboot computer after timeout of 5 Shell("Shutdown -r -t 5") ' Switches: ' -l Log off profile ' -s Shut down computer ' -r Restart computer ' -f Force applications to close ' -t Set a timeout for shutdownCodeArray ' -m \\computer name (Shutdown remote computer) ' -i Show the Shutdown GUI End Sub End Module البرنامج: Option Compare Database Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Const SW_SHOWNORMAL = 1 Private Sub cmd_change_Click() Dim SetLocaleInfo_File As String Dim Parameters As String SetLocaleInfo_File = CurrentProject.Path + "\SetLocaleInfo.exe" Parameters = comb_countries ShellExecute 0, "runas", SetLocaleInfo_File, Parameters, vbNullString, SW_SHOWNORMAL End Sub ارفقت لكم جدول لإسماء الدولة ورموزها: Code Country af-ZA Afrikaans (South Africa) ar-AE Arabic (U.A.E.) ar-BH Arabic (Bahrain) ar-DZ Arabic (Algeria) ar-EG Arabic (Egypt) ar-IQ Arabic (Iraq) ar-JO Arabic (Jordan) ar-KW Arabic (Kuwait) ar-LB Arabic (Lebanon) ar-LY Arabic (Libya) ar-MA Arabic (Morocco) ar-OM Arabic (Oman) ar-QA Arabic (Qatar) ar-SA Arabic (Saudi Arabia) ar-SY Arabic (Syria) ar-TN Arabic (Tunisia) ar-YE Arabic (Yemen) az-AZ Azeri (Latin) (Azerbaijan) az-AZ Azeri (Cyrillic) (Azerbaijan) be-BY Belarusian (Belarus) bg-BG Bulgarian (Bulgaria) bs-BA Bosnian (Bosnia and Herzegovina) ca-ES Catalan (Spain) cs-CZ Czech (Czech Republic) cy-GB Welsh (United Kingdom) da-DK Danish (Denmark) de-AT German (Austria) de-CH German (Switzerland) de-DE German (Germany) de-LI German (Liechtenstein) de-LU German (Luxembourg) dv-MV Divehi (Maldives) el-GR Greek (Greece) en-AU English (Australia) en-BZ English (Belize) en-CA English (Canada) en-CB English (Caribbean) en-GB English (United Kingdom) en-IE English (Ireland) en-JM English (Jamaica) en-NZ English (New Zealand) en-PH English (Republic of the Philippines) en-TT English (Trinidad and Tobago) en-US English (United States) en-ZA English (South Africa) en-ZW English (Zimbabwe) es-AR Spanish (Argentina) es-BO Spanish (Bolivia) es-CL Spanish (Chile) es-CO Spanish (Colombia) es-CR Spanish (Costa Rica) es-DO Spanish (Dominican Republic) es-EC Spanish (Ecuador) es-ES Spanish (Castilian) es-ES Spanish (Spain) es-GT Spanish (Guatemala) es-HN Spanish (Honduras) es-MX Spanish (Mexico) es-NI Spanish (Nicaragua) es-PA Spanish (Panama) es-PE Spanish (Peru) es-PR Spanish (Puerto Rico) es-PY Spanish (Paraguay) es-SV Spanish (El Salvador) es-UY Spanish (Uruguay) es-VE Spanish (Venezuela) et-EE Estonian (Estonia) eu-ES Basque (Spain) fa-IR Farsi (Iran) fi-FI Finnish (Finland) fo-FO Faroese (Faroe Islands) fr-BE French (Belgium) fr-CA French (Canada) fr-CH French (Switzerland) fr-FR French (France) fr-LU French (Luxembourg) fr-MC French (Principality of Monaco) gl-ES Galician (Spain) gu-IN Gujarati (India) he-IL Hebrew (Israel) hi-IN Hindi (India) hr-BA Croatian (Bosnia and Herzegovina) hr-HR Croatian (Croatia) hu-HU Hungarian (Hungary) hy-AM Armenian (Armenia) id-ID Indonesian (Indonesia) is-IS Icelandic (Iceland) it-CH Italian (Switzerland) it-IT Italian (Italy) ja-JP Japanese (Japan) ka-GE Georgian (Georgia) kk-KZ Kazakh (Kazakhstan) kn-IN Kannada (India) ko-KR Korean (Korea) kok-IN Konkani (India) ky-KG Kyrgyz (Kyrgyzstan) lt-LT Lithuanian (Lithuania) lv-LV Latvian (Latvia) mi-NZ Maori (New Zealand) mk-MK FYRO Macedonian (Former Yugoslav Republic of Macedonia) mn-MN Mongolian (Mongolia) mr-IN Marathi (India) ms-BN Malay (Brunei Darussalam) ms-MY Malay (Malaysia) mt-MT Maltese (Malta) nb-NO Norwegian (Bokm?l) (Norway) nl-BE Dutch (Belgium) nl-NL Dutch (Netherlands) nn-NO Norwegian (Nynorsk) (Norway) ns-ZA Northern Sotho (South Africa) pa-IN Punjabi (India) pl-PL Polish (Poland) ps-AR Pashto (Afghanistan) pt-BR Portuguese (Brazil) pt-PT Portuguese (Portugal) qu-BO Quechua (Bolivia) qu-EC Quechua (Ecuador) qu-PE Quechua (Peru) ro-RO Romanian (Romania) ru-RU Russian (Russia) sa-IN Sanskrit (India) se-FI Sami (Northern) (Finland) se-FI Sami (Skolt) (Finland) se-FI Sami (Inari) (Finland) se-NO Sami (Northern) (Norway) se-NO Sami (Lule) (Norway) se-NO Sami (Southern) (Norway) se-SE Sami (Northern) (Sweden) se-SE Sami (Lule) (Sweden) se-SE Sami (Southern) (Sweden) sk-SK Slovak (Slovakia) sl-SI Slovenian (Slovenia) sq-AL Albanian (Albania) sr-BA Serbian (Latin) (Bosnia and Herzegovina) sr-BA Serbian (Cyrillic) (Bosnia and Herzegovina) sr-SP Serbian (Latin) (Serbia and Montenegro) sr-SP Serbian (Cyrillic) (Serbia and Montenegro) sv-FI Swedish (Finland) sv-SE Swedish (Sweden) sw-KE Swahili (Kenya) syr-SY Syriac (Syria) ta-IN Tamil (India) te-IN Telugu (India) th-TH Thai (Thailand) tl-PH Tagalog (Philippines) tn-ZA Tswana (South Africa) tr-TR Turkish (Turkey) tt-RU Tatar (Russia) uk-UA Ukrainian (Ukraine) ur-PK Urdu (Islamic Republic of Pakistan) uz-UZ Uzbek (Latin) (Uzbekistan) uz-UZ Uzbek (Cyrillic) (Uzbekistan) vi-VN Vietnamese (Viet Nam) xh-ZA Xhosa (South Africa) zh-CN Chinese (S) zh-HK Chinese (Hong Kong) zh-MO Chinese (Macau) zh-SG Chinese (Singapore) zh-TW Chinese (T) zu-ZA Zulu (South Africa) مدة العمل ( ساعة ونصف ) SetLocaleInfo.rar

السلام عليكم ورحمة والله تعالى وبركاته طيب ببساطه انظر للسلسلة النصية الاتية "Moh8202281012343434" ونريد التعديل عليها لتظهر بهذا الشكل "Moh-820-228-101-234-343-4" او بهذا الشكل "Moh,820,228,101,234,343,4" او بهذا الشكل Moh820/228101/234343/4 يتم عمل ذلك من خلال الكود الاتى Function ReFormat(ByVal strText As String, Optional strSymbol As String = "-", Optional intCountDigits As Integer = 3) Dim i As Long ReFormat = "" For i = 0 To Len(strText) - 1 Step intCountDigits If i = 0 Then ReFormat = Mid(strText, i + 1, intCountDigits) Else ReFormat = ReFormat & strSymbol & Mid(strText, i + 1, intCountDigits) End If Next i End Function syntax code ReFormat(string ,Symbol, Count Digits) Result By default syntax used ReFormat(string) Symbol >-->> - Count Digits >-->> 3 اذا من خلال استدعاء الكود عن طريق البنية المفضلة الاتية: ReFormat(string) تحصل على اضافة العلامة - بعد كل 3 مواضع فى السلسلة النصية اما اذا اردت التعديل فى شكل الرمز وعدد المواضع يمكنك استخدام الكود الاتى : ReFormat(string ,Symbol, Count Digits) مثلا لو اردت استخدام الرمز $ بدلا من الرمز - وتريد وضع الرمز فى السلسلة النصية بعد كل خمس مواضع يكون الكود كالأتى: ReFormat(string ,"$", 5)

السلام عليكم ورحمة الله وبركاته... عود على بدء في موضوعي هذا: اقدم لكم النسخة الثانية من اداة رفع الملفات ونسخ الباك اب الى Google Drive لكن هذه المرة ستقوم الاداة بضغط الملف وتشفيرة بباسورد بأستخدام winRAR ومن ثم رفعه الى Google Drive لمنع اي شخص من الاطلاع على محتويات الملف المضغوط لان الضغط هنا سيكون Encrypt File Names بعبارة اخرى سيكون الملف المضغوط هكذا شكله: لن تستطيع ان تعرف ما يحويه الملف المضغوط من ملفات الا اذا قمت بوضع الباسورد. اضفت براميتر جديد على الاداة وهو باسورد الضغط، ستجدون كل شيء في ملف الاكسس، وباقي الامور شرحناها في الدرس السابق لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. GoogleDriveUploader_fixed.rar

السلام عليكم.. اداة صغيرة مكتوبة كـ مفتاح registry عند تشغيلها ستقوم باضافة خيار جديد في الزر الايمن للماوس وضيفته جلب مسار الملفات والمجلدات لسرعه الوصول لها في البرامج او غيرها.. الاداة ليست من كتابتي انما فقط قمت بالتعديل عليها.. سورس الاداة: Windows Registry Editor Version 5.00 ; ########################################## ; Application : Get files/directories path by right click windows ; Coded by : Dr.Hassanien (SEMO.Pa3x) ; Date : 28-2-2022 ; ########################################## [HKEY_CLASSES_ROOT\Allfilesystemobjects\shell\windows.copyaspath] "CanonicalName"="{707C7BC6-685A-4A4D-A275-3966A5A3EFAA}" "CommandStateHandler"="{3B1599F9-E00A-4BBF-AD3E-B3F99FA87779}" "CommandStateSync"="" "Description"="@shell32.dll,-30336" "Icon"="imageres.dll,-5302" "InvokeCommandOnSelection"=dword:00000001 "MUIVerb"="@shell32.dll,-30329" "VerbHandler"="{f3d06e7c-1e45-4a26-847e-f9fcdee59be0}" "VerbName"="copyaspath" بعد تشغيل الاداة اضغط كلك يمين على اي ملف في الكومبيوتر او اي مجلد وستظهر لك: بعد نسخ اي مسار قم بلصقه، مثال: تحميل الملف من المرفقات لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. AddToRightClickWindows.rar

اعرض الملف الأرشيف الالكترونى تجربة طريقة بحث جديدة جدا البرنامج متكامل مفتوح المصدر ويمكن التحكم والتغيير به ليصبح ملكك برنامج الأرشيف الألكترونى للملفات الصادرة والواردة ومحاضر اجتماع وعرض الملفات بطريقة الصحف عن أى شيىء وكل شيىء ويوجد بالبرنامج طريقة جديدة لعرض المرفقات المرتبطة مع السجل الحالى فقط أرجو من الأخوة الأفاضل التكرم بالتجربة والاطلاع والتقييم والتحسين أن أمكن الاستاذة الأفاضل البرنامج يشمل أعمال كاملة (المهمات الأساسية + نسخ احتياطية - حفظ المستندات خارج القاعدة - نسخ الملفات ونقلها من وألى الجهاز لأى مكان تختاره - امكانية اخفاء المرفقات واضهارها ....الخ ويشمل اعمال تحت التنفيذ (ادخال محاضر - وملفات متنوعة - تحكم بألوان النماذج وتغيير لها بضغطة واحدة ملحوظة هامة يجب الحاق المكتبات كما بالصورة المرفقة وتحميل برنامج اكروبات ريدر للسماح بالمكتبات بالاضافة والتمكين الباسورد تنحصر برقم 0000 لأى اختيار برجاء التقييم ووضع تعليق يتضمن اصدار الويندوز والأفيس الملف بحجم 2.90 MB وضعته على الميديا فير كما نصحنى رفاق المنتدى والاساتذة به وكل الشكر للاستاذ أبا جودى على الرابط التالى https://www.mediafire.com/file/gvp38c8299mk7yy/Data+Zero.rar/file صاحب الملف walid7799 تمت الاضافه 07 ديس, 2021 الاقسام قسم الأكسيس  

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

السلام عليكم، كثيراً ما ارى طلبات "كيفية عمل صلاحيات المستخدمين" قمت بعمل مثال بطريقة مبسطة جدا لكيفية عمل هذه الصلاحيات في تحديد فتح النماذج لمن لا يعرف ماذا اقصد بصلاحيات المستخدمين, مثال: اليوزر A غير مسموح له بفتح فورم الاعدادات مثلاً، اما اليوزر B مسموح له بفتح فورم الاعدادات اي سؤال انا موجود. تحياتي لكم Permission.accdb

السلام عليكم.. في درس اليوم سنقوم بحساب نسبة الربح من سعر الشراء وسعر البيع وسنقوم بحساب سعر البيع من خلال نسبة الربح -------------------------------------------------------------------------------------- المثال الأول: إذا تم شراء سلعة بسعر 450 دولار، وبيعها بسعر 500 دولار، فما هي نسبة الربح؟ الحل: القانون الرئيسي لنسبة الربح: (الربح/سعر الشراء)×100% أولاً: نحسب قيمة الربح لكي نعوضها في القانون في الأعلى الربح = سعر البيع - سعر الشراء 500-450 = 50 دولار. وبالتعويض في القانون الرئيسي: نسبة الربح = (50/450) × 100% = 11.11% -------------------------------------------------------------------------------------- أما لو اردنا حساب سعر البيع من خلال نسبة الربح: المثال الثاني: إذا تم شراء سلعة بسعر 10 دولار وكانت نسبة الربح 25%، فما هو سعر البيع؟ الحل: القانون الرئيسي لحساب سعر البيع من خلال نسبة الربح: (سعر الشراء * نسبة الربح) / 100 + سعر الشراء وبالتعويض في القانون الرئيسي: النتيجة = (10 * 25) / 100 + 10 = 12.5 تحياتي لكم..

السلام عليكم.. في بلدي العراق لدينا أقل عملة نقدية وهي 250 دينار عراقي احفظو هذا الرقم جيداً لأننا سنعود اليه اردت ان اقوم بعمل برنامج للأقساط فكان مبلغ القسط الكامل هو ( 10,000 عشرة الآف دينار عراقي ) وكانت مدة الأقساط هي ( 3 شهور ) اذن نقوم بتقسيم المبلغ على المدة لكي يظهر لنا قيمة القسط لكل شهر وعند التقسيم ظهرت الكارثة مبلغ غريب!!!!!!!!!! فلا هو 250 دينار ولا هو 500 دينار لا يمكن دفعة.. ماهو الحل؟؟ قمت بكتابة كود لحل هذه المشكلة، للأمانة الكود ليس من كتابتي 100% بل بنسبة 60% Public Function RoundTo(d, roundRate, RoundType) As Double d = Math.Round(d, 7) If d <> 0 And roundRate <> 0 Then d = Ceiling(d) Dim num As Double num = d Mod roundRate If num > 0 Then If RoundType = 1 Then d = d + roundRate - num ElseIf RoundType = 2 Then d = d - num ElseIf RoundType = 3 Then If num >= roundRate / 2 Then d = d + roundRate - num Else d = d - num End If End If End If End If RoundTo = d End Function Public Function Ceiling(ByVal x As Double, Optional ByVal Factor As Double = 1) As Double ' X is the value you want to round ' Factor is the optional multiple to which you want to round, defaulting to 1 Ceiling = (Int(x / Factor) - (x / Factor - Int(x / Factor) > 0)) * Factor End Function الاستخدام: Private Sub cmd_calc_Click() Dim TotalPrice, Result As Long Dim Duration, i As Integer TotalPrice = 10000 Duration = 3 i = 1 Result = TotalPrice / Duration Do While i <= Duration MsgBox RoundTo(Result, 250, 2) i = i + 1 Loop End Sub ستظهر لنا النتيجة على شكل لووب مقسمة لإجزاء سيتم جبر النتيجة من 3,333333 الى 250 فتكون: 3,250 الف دينار لـ 3 دفعات ويمكنكم إستخدام الكود حسب العملة لديكم، بإستبدال 250 لإصغر قيمة عملة لديكم. تحياتي لكم

السلام عليكم، أحياناً تواجهنا مشكلة في الأكسس وهي تحول الارقام الى العربية خصوصاً اذا كان بجانب الرقم حروف عربية لذلك دعونا نختصر الوقت على العميل ونقوم بتعديل تنسيقات التاريخ والارقام..الخ برمجياً بدون الطلب من العميل تعديلها يدوياً اقدم لكم فنكشن للتعديل، يمكنكم التعديل والإضافة بحسب ماتجدوه مناسباً. Public Sub EditControlPanelInternational() 'Define a key registry path Dim strComputer Dim objRegistry Dim strKeyPath Dim strValueName Dim getValue Dim regKeyPath Dim strLocaleName, strCountry, strshortDateValue, strlongDateValue, strshortTimeValue, strlongTimeValue, strfirstDayOfWeekValue Const HKEY_CURRENT_USER = &H80000001 strComputer = "." Set objRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv") regKeyPath = "Control Panel\International" strLocaleName = "en-US" strCountry = "United States" strshortDateValue = "yyyy-MM-dd" strlongDateValue = "dddd, MMMM d, yyyy" strshortTimeValue = "h:mm tt" strlongTimeValue = "h:mm:ss tt" strfirstDayOfWeekValue = "6" srtnativedigits = "0123456789" objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "LocaleName", strLocaleName objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sCountry", strCountry objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sShortDate", strshortDateValue objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sLongDate", strlongDateValue objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sShortTime", strshortTimeValue objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sTimeFormat", strlongTimeValue objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "iFirstDayOfWeek", strfirstDayOfWeekValue objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sNativeDigits", srtnativedigits Debug.Print "Successfully changed system regional settings." End Sub للأمانة الفنكشن من كتابة saf لذلك انا قمت بإضافة السطر srtnativedigits = "0123456789" objRegistry.SetStringValue HKEY_CURRENT_USER, regKeyPath, "sNativeDigits", srtnativedigits لتغيير تنسيق الأرقام من عربي إلى انجليزي ومن ثم قمت بنقله لكم.

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته في هذا الدرس سأقدم نظرة عامة، ومُقدمة على التعابير القياسية Regular Expression وذلك لأهميتها الكبيرة في البرمجة. ملاحظة: لن اتطرق لكيفية كتابة الـ patterns نضرة لصعوبته على البعض لانه يحتاج اساسيات ومقدمات. في هذا الدرس سوف أستخدم بإذن الله لغة VBA في عمل اختبارات على الـ Regular Expression تعريف Regular Expression: هو كائن يصف نمطًا من المحارف ( أو الكلمات ). تعريف أعمق للتعابير القياسية: هي سلسلة من الأحرف التي تحدد نمطًا للبحث داخل النصوص (String) أو للمطابقة بين سلاسل من الأحرف. الهدف من التعاببير القياسية هو تسهيل عمليات البحث والاستبدال داخل النصوص، وتستخدم غالبًا في عمليات التحقق (Validation) وعمليات البحث (Searching) وايضًا في الحماية. ولتوضيح الفكرة بشكل أفضل بإمكاننا وضع مثال بسيط واقتراح الحلول له ثم بعد ذلك تبسيط الحل باستخدام التعابيير القياسية والتي سنرمز لها لاحقًا بـ RegExp. لنفرض أننا سنقوم ببرمجة نموذج تسجيل وستكون المدخلات المطلوبة ( اسم المستخدم - Username & البريد الإلكتروني - Email ) ونريد أن نتأكد من التالي: اسم المستخدم يجب أن يكون خليط من حروف وأرقام ، والرموز التالية فقط (_-.). البريد الإلكتروني يجب أن يكون بالشكل التالي : email_name@domain_name.top-level-domain مثال: cielblog@hotmail.com. وسيكون شكل نموذج التسجيل كالأتي: الحلول المقترحة كثيرة، مثلًا لكي نتأكد أن إسم المستخدم خالٍ من المسافات والرموز نحتاج لعمل تصفية (Filter) له، والتأكد اولًا من وجود مسافات واستبدالها مثلًا بالرمز _ او ازالتها كليًا، بعد ذلك تنقيح الاسم من الرموز الممنوعة ... عملية طويلة 🤔 اما البريد الإلكتروني يجب ان نتأكد اولًا من خلوه من المسافات ايضًا، والرموز الممنوعة في اغلب مشغلات البريد الإلكتروني، بعد ذلك التحرك قليلًا للتأكد أنّ ماقبل علامة @ هو String ومابعده String ثم التحقق أن ماقبل علامة النقطة - dot - هو String ومابعده هو top-level-domain ... عملية أطول 🤔 في التعابيير القياسية يمكننا اختصار كل هذه العمليات بسطر واحد أو نصف سطر حتى، وفي درسنا هذا سنتعلم كيف نحل مشكلتنا هذه ان شاء الله. أولاً: انسخ الفنكشن الآتي.. ' ----------------------------------------------------------------------' ' Return True if the given string value matches the given Regex pattern ' ' ----------------------------------------------------------------------' Public Function RegexMatch(value As Variant, pattern As String) As Boolean If IsNull(value) Then Exit Function ' Using a static, we avoid re-creating the same regex object for every call ' Static regex As Object ' Initialise the Regex object ' If regex Is Nothing Then Set regex = CreateObject("vbscript.regexp") With regex .Global = True .IgnoreCase = True .MultiLine = True End With End If ' Update the regex pattern if it has changed since last time we were called ' If regex.pattern <> pattern Then regex.pattern = pattern ' Test the value against the pattern ' RegexMatch = regex.test(value) End Function لاحظو الفنكشن يتكون من براميترات 2 الأول القيمة المراد اجراء التحقق عليها والبراميتر الثاني هو معيار التحقق ولو اردت ان اكتب تحقق لإسم المستخدم، سأكتب: If RegexMatch("semo", "^[\w_-]+$") = True Then MsgBox "Correct username", vbInformation, "CORRECT" Else MsgBox "Wrong username", vbCritical, "ERROR!" End If لو اردت ان اكتب تحقق للبريد الإلكتروني سأكتب: If RegexMatch("test@gmail.com", "[A-Za-z0-9_\-.]+@[A-Za-z0-9_\-.]+\.(com|org|net)") = True Then MsgBox "Correct email", vbInformation, "CORRECT" Else MsgBox "Wrong email", vbCritical, "ERROR!" End If للفائدة، google ممتلئ بالـ patterns ماعليك فقط ان تبحث قليلاً وستجد الباترن المطلوب ☺️ بالتوفيق للجميع.

السلام عليكم، لو اردنا ان نقوم بحفظ السجلات المحددة في النموذج الفرعي سنلجئ لعمل CheckBox في الجدول ومن ثم نقوم بعمل استعلام يقوم بفلترة جميع الـ Checkbox التي تكون قيمتها True ومن ثم نقوم بحفظها. لكن! ماذا لو كانت قاعدة البيانات تعمل بنظام الشبكة ( Multi Users ) اذا قام المستخدم رقم 1 بوضع علامة صح على مثلا مادة ( برتقال ) وقام المستخدم رقم 2 بوضع علامة صح على مثلا مادة ( رمان ) عندما يضغط اي مستخدم على حفظ البيانات فـ ستحفظ البيانات وتكون النتيجة خاطئة لان البيانات ليست هي المطلوبة انا اخترت ( برتقال ) فأتتني النتيجة ( برتقال + رمان ) وكذا بالنسبة للمستخدم الثاني والثالث وغيرهم، ممن يعملون على قاعدة البيانات بوقت واحد، صراحة واجهتني هالمشكلة لكن وجدت الحل لها كما انني رأيت موضوع للأخ ابا جودي يتكلم عن هذه المشكلة ارفقت لكم طريقة مختلفة في تحديد السجلات وهي الضغط على مُحدد السجلات للأمانة الطريقة ليست كلها من برمجتي الحقوق لـ arnelgp انا فقط قم اضافة وتعديل بعض الامور البسيطة تحياتي لكم RecordSelectorClick.accdb

السلام عليكم.. في البداية شكرا لكل من قام بالرد على موضوعي السابق في وقتنا الحاضر ارى ان اغلب البرامج في السوق هي من هذا النوع وللأسف لم اجد التفاعل الكبير معها، خصوصا في موضوعي في الأعلى عموما، قمت ببرمجة برنامج صغير لإدارة المخزن، وانتضر منكم التجربة للوقوع على الأخطاء ومحاولة تصحيحها علماً، ان النسخة مؤقتة وسوف تُغلق بعد تصحيح الأخطاء. باسورد فتح البرنامج = 313 تحياتي للجميع. store_manager.rar