Moosak

السلام عليكم ورحمة الله وبركاته يسرني اليوم أن أقدم لكم هذه الهدية المتميزة والرائعة (مكتبة الأكواد الخاصة) :: الإصدار الثالث :: مكتبة عامرة بمئات الأكواد VBA داعمة للمبرمجين وجزء لا يتجزأ من عملهم. تختصر الوقت وتسهل العمل على مصممي البرامج. وهي مكتبة عامة يمكن استخدامها لأي لغات برمجية أخرى . من مميزات المكتبة : - أكثر من 360 كود ودالة في مختلف الفنون والمجالات . - قابلة لحفظ مرفقات مع الكود لدعم التطبيق. - يمكنك إضافة أكوادك الخاصة لتكون مكتبة داعمة لكل مبرمج. - سهلة الاستخدام . تحميل المكتبة : مكتبة الأكواد الخاصة zip.zip ولا تنسوني من صالح دعواتكم 🙂🌹

أدخل في الماكرو الموجود على الزر وغير طريقة عرض التقرير إلى > طباعة .. بدل معاينة الطباعة

وعليكم السلام ورحمة الله وبركاته .. جرب هذه الفكرة 🙂 Patient Sample Tracking.accdb

أو يمكنك استخدام هذه الأكواد البديلة : 3 دوال لـ ( نسخ - لصق - تفريغ الذاكرة ) شرح الكود: ضع الكود كاملا في موديول ثم استخدمه في البرنامج كما هو واضح في الأسفل .. الكود: '==================================================(Copy) Public Function CopyText(ByVal Text As Variant) As Boolean CopyText = CreateObject("htmlfile").ParentWindow.ClipboardData.SetData("Text", Text) End Function '==================================================(Paste) Public Function PasteText() As String On Error Resume Next PasteText = CreateObject("htmlfile").ParentWindow.ClipboardData.getData("Text") End Function '==================================================(Clear The ClipBoard) Public Function ClearClipBoardText() As Boolean ClearClipBoardText = CreateObject("htmlfile").ParentWindow.ClipboardData.clearData("Text") End Function طريقة الاستدعاء (الاستخدام): CopyText(Text) <------ للنسخ PasteText() <------ للصق ClearClipBoardText() <------ تفريغ الذاكرة

عمي قاسم .. ممكن تغير مكان الحفظ الإفتراضي إلى المجلد اللي تريده .. ( اتبع الخطوات : ) 🙂 ( الخطوة رقم 4 لعمل مجلد جديد للبرنامج بدل ما تحفظه على ال C مباشرة )

جربت التحميل هذه المرة ولم أواجه أي مشكلة ولله الحمد 🙂 ولكن كما أخبرتك سابقا .. الحساب التجريبي ممنوع من عمل أي شيء .. فقط فتح البرنامج وإغلاقه عندي سؤال : ما هو البرنامج الذي تستخدمه لعمل التنصيب ؟

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

ما رضت الروابط تفتح 😅🖐 جربت 3 مستعرضات .. تظهر لي صفحة بيضاء فارغة

وعليكم السلام ورحمة الله وبركاته 🙂 هل هذا ما تريده ؟ طبعا للحصول على هذه البيانات .. أنسخ الموديول المرفق كاملا كما هو .. وهو يحتوي على العديد من الدوال الخاصة بالتعامل مع الملفات من جميع النواحي ( نسخ - لصق- نقل - حذف - ودوال للحصول على بيانات الملفات كما هو واضح لديك .. 🙂 ) ثم في مربعات النص التي في النموذج أنظر لطريقة إحضار بيانات الملفات .. باستخدام الدوال المرفقة في الموديول .. وكذلك في كل دالة مكتوب فيها بالتفصيل كيفية استخدامها 🙂 TknDate.accdb

أخي سامر تم دمج الموضوعين لاحتوائهما على نفس الطلب .. 🙂 أبلغني إن كانا غير متشابهين ..

هذه أحد الطرق من مكتبتي : *إظهار رسالة إشعار فوق شريط الويندوز Show Balloon Tooltip* وهناك ملف مرفق كمثال .. شكل الرسالة : *شرح الكود:* نظام إشعارات أو رسائل فوق شريط الويندوز .. يمكن وضعها عند أي حدث تريد أو عند زر أمر أو .. أو .. أو .. أو .. ويمكنك تغيير الأيقونة التي تظهر جنب الرسالة والأيقونة التي تظهر برأس الرسالة كذلك *الكود:* ' قم بنقل الموديول والكلاس الموجدان في الملف المرفق إلى برنامجك ومن ثم تضبط رسالتك بالطريقة المذكورة في الأسفل، أو انسخ الأكواد من هنا كاتالي : ' أضف موديول جديد باسم Mod_Balloon_Msg ' وألصق فيه الكود التالي: '================================= Option Compare Database Dim bt As CLS_BALLOON_MSG Public Enum btIcon btNone btInformation btWarning btCritical End Enum Public Function ShowBalloonTooltip(strHeading As String, strMessage As String, lngIcon As btIcon) 'Wrapper function to call the class so it can be called from an add-in code library Set bt = New CLS_BALLOON_MSG With bt .Heading = strHeading .Message = strMessage .Icon = lngIcon .Show End With End Function Public Function HideIcon() If Not bt Is Nothing Then With bt .Hide End With End If End Function '=====================(تم أنشيء موديول من نوع كلاس Class واسمه :)==(Mod_Balloon_Msg)==( وألصق فيه التالي:) Option Compare Database Option Explicit Private mlngIcon As Long Private mstrHeading As String Private mstrMessage As String Private Const APP_SYSTRAY_ID = 999 Private Const NOTIFYICON_VERSION = &H3 Private Const NIF_MESSAGE = &H1 Private Const NIF_ICON = &H2 Private Const NIF_TIP = &H4 Private Const NIF_STATE = &H8 Private Const NIF_INFO = &H10 Private Const NIM_ADD = &H0 Private Const NIM_MODIFY = &H1 Private Const NIM_DELETE = &H2 Private Const NIM_SETFOCUS = &H3 Private Const NIM_SETVERSION = &H4 Private Const NIM_VERSION = &H5 Private Const NIS_HIDDEN = &H1 Private Const NIS_SHAREDICON = &H2 Private Const NIIF_NONE = &H0 Private Const NIIF_INFO = &H1 Private Const NIIF_WARNING = &H2 Private Const NIIF_ERROR = &H3 Private Const NIIF_GUID = &H5 Private Const NIIF_ICON_MASK = &HF Private Const NIIF_NOSOUND = &H10 Private Const WM_USER = &H400 Private Const NIN_BALLOONSHOW = (WM_USER + 2) Private Const NIN_BALLOONHIDE = (WM_USER + 3) Private Const NIN_BALLOONTIMEOUT = (WM_USER + 4) Private Const NIN_BALLOONUSERCLICK = (WM_USER + 5) Private Const NOTIFYICONDATA_V1_SIZE As Long = 88 Private Const NOTIFYICONDATA_V2_SIZE As Long = 488 Private Const NOTIFYICONDATA_V3_SIZE As Long = 504 Private NOTIFYICONDATA_SIZE As Long Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type 'API updated by Colin Riddington - Oct 2018 #If VBA7 Then Private Type NOTIFYICONDATA cbSize As Long hWnd As LongPtr uId As Long uFlags As Long uCallbackMessage As Long hIcon As LongPtr szTip As String * 128 dwState As Long dwStateMask As Long szInfo As String * 256 uTimeoutAndVersion As Long szInfoTitle As String * 64 dwInfoFlags As Long guidItem As GUID End Type #Else Private Type NOTIFYICONDATA cbSize As Long hWnd As Long uId As Long uFlags As Long uCallbackMessage As Long hIcon As Long szTip As String * 128 dwState As Long dwStateMask As Long szInfo As String * 256 uTimeoutAndVersion As Long szInfoTitle As String * 64 dwInfoFlags As Long guidItem As GUID #End If 'APIs to handle system notifications #If VBA7 Then 'https://learn.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-shell_notifyicona 'Sends a message to the taskbar's status area. Private Declare PtrSafe Function Shell_NotifyIcon Lib "shell32.dll" _ Alias "Shell_NotifyIconA" _ (ByVal dwMessage As LongPtr, _ lpData As NOTIFYICONDATA) As LongPtr 'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-getfileversioninfosizea 'Determines whether the operating system can retrieve version information for a specified file. 'If version information is available, GetFileVersionInfoSize returns the size, in bytes, of that information. Private Declare PtrSafe Function GetFileVersionInfoSize Lib "version.dll" _ Alias "GetFileVersionInfoSizeA" _ (ByVal lptstrFilename As String, _ lpdwHandle As Long) As Long 'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-getfileversioninfoa 'Retrieves version information for the specified file. Private Declare PtrSafe Function GetFileVersionInfo Lib "version.dll" _ Alias "GetFileVersionInfoA" _ (ByVal lptstrFilename As String, _ ByVal dwHandle As LongPtr, _ ByVal dwLen As LongPtr, _ lpData As Any) As Long 'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-verqueryvaluea 'Retrieves specified version information from the specified version-information resource. 'To retrieve the appropriate resource, before you call VerQueryValue, you must first call the GetFileVersionInfoSize function, and then the GetFileVersionInfo function. Private Declare PtrSafe Function VerQueryValue Lib "version.dll" _ Alias "VerQueryValueA" _ (pBlock As Any, _ ByVal lpSubBlock As String, _ lpBuffer As Any, _ nVerSize As Long) As LongPtr 'https://learn.microsoft.com/en-us/previous-versions/windows/desktop/legacy/aa366535(v=vs.85) 'Copies a block of memory from one location to another. Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _ Alias "RtlMoveMemory" _ (Destination As Any, _ Source As Any, _ ByVal Length As LongPtr) #Else Private Declare Function Shell_NotifyIcon Lib "shell32.dll" _ Alias "Shell_NotifyIconA" _ (ByVal dwMessage As Long, _ lpData As NOTIFYICONDATA) As Long Private Declare Function GetFileVersionInfoSize Lib "version.dll" _ Alias "GetFileVersionInfoSizeA" _ (ByVal lptstrFilename As String, _ lpdwHandle As Long) As Long Private Declare Function GetFileVersionInfo Lib "version.dll" _ Alias "GetFileVersionInfoA" _ (ByVal lptstrFilename As String, _ ByVal dwHandle As Long, _ ByVal dwLen As Long, _ lpData As Any) As Long Private Declare Function VerQueryValue Lib "version.dll" _ Alias "VerQueryValueA" _ (pBlock As Any, _ ByVal lpSubBlock As String, _ lpBuffer As Any, _ nVerSize As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" _ Alias "RtlMoveMemory" _ (Destination As Any, _ Source As Any, _ ByVal Length As Long) #End If Private Const WM_GETICON = &H7F Private Const WM_SETICON = &H80 Private Const IMAGE_BITMAP = 0 Private Const IMAGE_ICON = 1 Private Const IMAGE_CURSOR = 2 Private Const LR_LOADFROMFILE = &H10 Private Const ICON_SMALL = 0& Private Const ICON_BIG = 1& #If VBA7 Then 'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-loadimagea 'Loads an icon, cursor, animated cursor, or bitmap. Private Declare PtrSafe Function apiLoadImage Lib "user32" _ Alias "LoadImageA" _ (ByVal hInst As LongPtr, _ ByVal lpszName As String, _ ByVal uType As LongPtr, _ ByVal cxDesired As LongPtr, _ ByVal cyDesired As LongPtr, _ ByVal fuLoad As LongPtr) _ As Long 'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-sendmessagea 'Sends the specified message to a window or windows. 'The SendMessage function calls the window procedure for the specified window and does not return until the window procedure has processed the message. Private Declare PtrSafe Function apiSendMessageLong Lib "user32" _ Alias "SendMessageA" _ (ByVal hWnd As LongPtr, _ ByVal wMsg As Long, _ ByVal wParam As LongPtr, _ ByVal lParam As LongPtr) _ As LongPtr #Else Private Declare Function apiLoadImage Lib "user32" _ Alias "LoadImageA" _ (ByVal hInst As Long, _ ByVal lpszName As String, _ ByVal uType As Long, _ ByVal cxDesired As Long, _ ByVal cyDesired As Long, _ ByVal fuLoad As Long) _ As Long Private Declare Function apiSendMessageLong Lib "user32" _ Alias "SendMessageA" _ (ByVal hWnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) _ As Long #End If Private Const SHGFI_ICON = &H100 Private Const SHGFI_DISPLAYNAME = &H200 Private Const SHGFI_TYPENAME = &H400 Private Const SHGFI_ATTRIBUTES = &H800 Private Const SHGFI_ICONLOCATION = &H1000 Private Const FILE_ATTRIBUTE_NORMAL = &H80 Private Const MAX_PATH = 260 Private Type SHFILEINFO hIcon As Long iIcon As Long dwAttributes As Long szDisplayName As String * MAX_PATH szTypeName As String * 80 End Type #If VBA7 Then 'https://learn.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-shgetfileinfoa 'Retrieves information about an object in the file system, such as a file, folder, directory, or drive root. Private Declare PtrSafe Function apiSHGetFileInfo Lib "shell32.dll" _ Alias "SHGetFileInfoA" _ (ByVal pszPath As String, _ ByVal dwFileAttributes As LongPtr, _ psfi As SHFILEINFO, _ ByVal cbSizeFileInfo As LongPtr, _ ByVal uFlags As LongPtr) _ As LongPtr 'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-destroyicon 'Destroys an icon and frees any memory the icon occupied. Private Declare PtrSafe Function apiDestroyIcon Lib "user32" _ Alias "DestroyIcon" _ (ByVal hIcon As LongPtr) _ As LongPtr #Else Private Declare Function apiSHGetFileInfo Lib "shell32.dll" _ Alias "SHGetFileInfoA" _ (ByVal pszPath As String, _ ByVal dwFileAttributes As Long, _ psfi As SHFILEINFO, _ ByVal cbSizeFileInfo As Long, _ ByVal uFlags As Long) _ As Long Private Declare Function apiDestroyIcon Lib "user32" _ Alias "DestroyIcon" _ (ByVal hIcon As Long) _ As Long #End If Private psfi As SHFILEINFO Private Const SW_HIDE = 0 Private Const SW_SHOWNORMAL = 1 Private Const SW_SHOWMINIMIZED = 2 Private Const SW_SHOWMAXIMIZED = 3 #If VBA7 Then 'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-showwindow 'Sets the specified window's show state e.g. normal/maximized/minimized/restore Private Declare PtrSafe Function apiShowWindow Lib "user32" _ Alias "ShowWindow" _ (ByVal hWnd As LongPtr, _ ByVal nCmdShow As LongPtr) _ As LongPtr #Else Private Declare Function apiShowWindow Lib "user32" _ Alias "ShowWindow" _ (ByVal hWnd As Long, _ ByVal nCmdShow As Long) _ As Long #End If Private Sub ShellTrayAdd() Dim nID As NOTIFYICONDATA If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion With nID .cbSize = NOTIFYICONDATA_SIZE .hWnd = Application.hWndAccessApp .uId = APP_SYSTRAY_ID .uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP .dwState = NIS_SHAREDICON .hIcon = fSetIcon(GetAppIcon) .szTip = "DHLGM Message Service" & vbNullChar .uTimeoutAndVersion = NOTIFYICON_VERSION End With Call Shell_NotifyIcon(NIM_ADD, nID) Call Shell_NotifyIcon(NIM_SETVERSION, nID) End Sub Private Sub ShellTrayRemove() Dim nID As NOTIFYICONDATA If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion With nID .cbSize = NOTIFYICONDATA_SIZE .hWnd = Application.hWndAccessApp .uId = APP_SYSTRAY_ID End With Call Shell_NotifyIcon(NIM_DELETE, nID) Call apiDestroyIcon(nID.hIcon) End Sub Private Sub ShellTrayModifyTip(nIconIndex As Long) Dim nID As NOTIFYICONDATA If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion With nID .cbSize = NOTIFYICONDATA_SIZE .hWnd = Application.hWndAccessApp .uId = APP_SYSTRAY_ID .uFlags = NIF_INFO .dwInfoFlags = nIconIndex .szInfoTitle = mstrHeading & vbNullChar .szInfo = mstrMessage & vbNullChar End With Call Shell_NotifyIcon(NIM_MODIFY, nID) End Sub Private Sub SetShellVersion() Select Case True Case IsShellVersion(6) NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V3_SIZE Case IsShellVersion(5) NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V2_SIZE Case Else NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V1_SIZE End Select End Sub #If VBA7 Then Private Function IsShellVersion(ByVal Version As LongPtr) As Boolean Dim lpBuffer As LongPtr #Else Private Function IsShellVersion(ByVal Version As Long) As Boolean Dim lpBuffer As Long #End If Dim nBufferSize As Long Dim nUnused As Long 'Dim lpBuffer As Long Dim nVerMajor As Integer Dim bBuffer() As Byte Const sDLLFile As String = "shell32.dll" nBufferSize = GetFileVersionInfoSize(sDLLFile, nUnused) If nBufferSize > 0 Then ReDim bBuffer(nBufferSize - 1) As Byte Call GetFileVersionInfo(sDLLFile, 0&, nBufferSize, bBuffer(0)) If VerQueryValue(bBuffer(0), "\", lpBuffer, nUnused) = 1 Then CopyMemory nVerMajor, ByVal lpBuffer + 10, 2 IsShellVersion = nVerMajor >= Version End If End If End Function Private Function GetSelectedOptionIndex() As Long GetSelectedOptionIndex = 2 End Function Public Property Get Icon() As btIcon Icon = mlngIcon End Property Public Property Let Icon(ByVal lngIcon As btIcon) mlngIcon = lngIcon End Property Public Property Get Heading() As String Heading = mstrHeading End Property Public Property Let Heading(ByVal strHeading As String) mstrHeading = strHeading End Property Public Property Get Message() As String Message = mstrMessage End Property Public Property Let Message(ByVal strMessage As String) mstrMessage = strMessage End Property Public Sub Show() Call ShellTrayAdd ShellTrayModifyTip mlngIcon End Sub Public Sub Hide() ShellTrayRemove End Sub Private Function fSetIcon(strIconPath As String) As Long Dim hIcon As Long hIcon = apiLoadImage(0&, strIconPath, IMAGE_ICON, 16&, 16&, LR_LOADFROMFILE) If hIcon Then fSetIcon = hIcon End If End Function Public Function GetAppIcon() As String Dim dbs As DAO.Database, prp As Property Const conPropNotFoundError = 3270 On Error GoTo GetAppIcon_Error Beep Set dbs = CurrentDb GetAppIcon = dbs.Properties("AppIcon") ExitHere: Exit Function GetAppIcon_Error: Select Case Err.Number Case 3270 'PropertyC Not Found 'db doesn't have an associated icon - no message needed ' MsgBox "Current Database needs to have a custom icon", vbCritical, "No Icon Found" Resume ExitHere Case Else MsgBox "An Unexpected Error has occured please inform IT Support Error " & Err.Number & " " & Err.Description & " in procedure GetAppIcon of Class Module BalloonTooltip", vbCritical, "db2" Resume ExitHere End Select 'Debug Only Resume End Function *طريقة الاستدعاء (الاستخدام):* ShowBalloonTooltip "عنوان الرسالة", "نص الرسالة", btInformation msg Balloon.accdb

الآن لديك جدول به كل التعديلات .. يمكنك الآن إضافة الطريقة التي تناسبك لعرض هذه الإشعارات كيفما تشاء 🙂

وعليك السلام ورحمة الله وبركاته أخي @Foksh 🙂 برنامج وتصميم جميل جدا ماشاء الله .. وفقك الله 🌹 الظاهر أنك وضعت فيه خلاصة الخبرات والأفكار تبارك الرحمن 🙂 أعجبتني طريقة التنصيب وإعدادت البداية .. ولكن واجهتني عدة أمور قد تواجه الآخرين أيضا 😅 1- برامج الفيروسات تعتبر الملف كفيروس .. لذلك ستضطر لإيقاف برنامج الفيروسات قبل فك الضغط . 2- تقريبا 95% من الأزرار والخدمات لا تعمل في النسخة التجريبية لعدم وجود صلاحيات ... فقط تظهر هذه الرسالة .. : والأصل أن تكون النسخة التجريبية كاملة الصلاحيات ولكن لفترة محدودة .. أو لعدد محدود من السجلات ( وجهة نظر ) 🙂 . 3- ملف الجداول غير محمي .. يمكن فتحه بسهولة والعبث بمحتوياته .. أغلقة برقم سري .. 4- تحذيرات الاستعلامات الإجرائية تظهر للمستخدمين .. وهي تعتبر مزعجة نوعا ما ..😅🖐🏼️ 5- لعبة أكس أو .. ما فيها زر خروج 😁 6- الأصناف لا تظهر في شاشة البحث عن الأصناف... ولا شاشة الاستعلام عن أرصدة الأصناف. مع تمنياتي لك بالتوفيق 🙂 🌹

تكرما أرفق النموذج مع الجدول الخاص به .

نقلت لك دالة كنت صممتها في أحد برامجي لتتبع التعديلات على السجلات .. 🙂 وهذه النتيجة : والدالة تتابع جميع هذه العمليات : ( إضافة سجل جديد - التعديل على السجلات - حذف السجلات ) الدالة : Option Compare Database Option Explicit Public Enum NotificationTypeEnum إضافة_سجل_جديد = 1 تعديل_البيانات = 2 حذف_السجل = 3 End Enum ' [NotfID], [FormName], [Type], [Action], [ByUser], [DateTime], [Done] Public Function AddNotification(strFormName As String, NotificationType As NotificationTypeEnum, _ Action As String) As Boolean 'دالة إضافة بيانات سجل التعديلات على سجلات البرنامج On Error GoTo Error_Handler Dim strSQL As String Dim UserName As String Dim NotfTxtType As String Select Case NotificationType Case Is = 1: NotfTxtType = "إضافة سجل جديد" Case Is = 2: NotfTxtType = "تعديل البيانات" Case Is = 3: NotfTxtType = "حذف السجل" End Select AddNotification = True UserName = Environ("UserName") strSQL = "INSERT INTO EditsLog_T ( [FormName], [Type], [Action], [ByUser]) " & _ " VALUES ('" & strFormName & "' ,'" & NotfTxtType & "' ,'" & Action & "' , '" & UserName & "' );" CurrentDb.Execute strSQL Error_Handler_Exit: On Error Resume Next Exit Function Error_Handler: If Err.Number = 0 Then Resume Next MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: Insert2History" & vbCrLf & _ "Error Description: " & Err.Description & _ Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _ , vbOKOnly + vbCritical, "Code: AddNotification" AddNotification = False Resume Error_Handler_Exit End Function Sub testNotf() Debug.Print AddNotification("نموذج الحركات", تعديل_البيانات, "تفاصيل التعديل") End Sub الأكواد في النموذج : Private Function Add2History() 'دالة إضافة التعديلات لهذا النموذج Dim strChange As String strChange = "في السجل رقم ( " & Me.PreCode & " ) تم التعديل على الحقل( " & Screen.ActiveControl.Name & " ) مـن : " & Screen.ActiveControl.OldValue & vbNewLine & "إلى : " & Screen.ActiveControl.Text 'Debug.Print strChange Call AddNotification(Me.Name, تعديل_البيانات, strChange) End Function Private Sub Form_AfterInsert() AddNotification Me.Name, إضافة_سجل_جديد, "تم إضافة السجل : " & Me.PreCode End Sub Private Sub Form_Delete(Cancel As Integer) AddNotification Me.Name, حذف_السجل, "تم حذف السجل : " & Me.PreCode End Sub ملفك بعد التعديل : QRSystem1.zip

أين وضعت أنت هذه المعادلة ؟ هل هي في الجدول؟ أم الاستعلام؟ أم النموذج؟ أم في الكود ؟

كبداية إن شاء الله ووضع القاعدة الرئيسية لموضوع التوزيع ،، 🙂 قمت بطلب عمل التوزيع حسب الشروط المذكورة من موقع الذكاء الاصطناعي .. فكان هذا جوابه : --------------------------------------------------------------------------------------------------------------------- التحدي الذي واجهته في طلبك هو معقد نوعًا ما ويتطلب تحليلًا دقيقًا وتنفيذًا متقنًا. للأسف، لا يمكنني تقديم الكود الكامل والنهائي هنا بسبب تعقيد المطلوب. ومع ذلك، يمكنني تقديم نمط عام لكيفية تنفيذ هذا التحدي باستخدام VBA في Microsoft Access. ستحتاج إلى تخصيص هذا النمط وفقًا لاحتياجاتك وبنية قاعدة البيانات الخاصة بك. Sub DistributeLessons() Dim startDate As Date Dim endDate As Date Dim currentWeek As Integer Dim weekStartDate As Date Dim weekEndDate As Date Dim studentRS As Recordset Dim teacherRS As Recordset Dim lessonRS As Recordset Dim vacationRS As Recordset ' Set start date and end date startDate = #8/1/2023# endDate = #8/31/2023# ' Set up recordsets for students, teachers, lessons, and vacations Set studentRS = CurrentDb.OpenRecordset("Tbl_Students") Set teacherRS = CurrentDb.OpenRecordset("Tbl_Teachers") Set lessonRS = CurrentDb.OpenRecordset("Tbl_Lessons") Set vacationRS = CurrentDb.OpenRecordset("Tbl_Vacations") ' Loop through the weeks in the month currentWeek = 1 weekStartDate = startDate Do While weekStartDate <= endDate weekEndDate = DateAdd("d", 6, weekStartDate) ' Assuming Sunday is the last day of the week ' Loop through each student studentRS.MoveFirst Do While Not studentRS.EOF ' Check if the student has lessons left for the week Dim lessonsLeft As Integer lessonsLeft = 2 ' Loop through each teacher teacherRS.MoveFirst Do While Not teacherRS.EOF ' Check if the teacher is on vacation for any day in the week Dim isOnVacation As Boolean isOnVacation = False vacationRS.MoveFirst Do While Not vacationRS.EOF If vacationRS!TeacherID = teacherRS!TeachersID And _ vacationRS!StartDateVacation <= weekEndDate And _ vacationRS!EndDateVacation >= weekStartDate Then isOnVacation = True Exit Do End If vacationRS.MoveNext Loop ' If the teacher is not on vacation, assign lessons If Not isOnVacation Then Dim lessonsAssigned As Integer lessonsAssigned = 0 ' Assign lessons to the teacher for the week ' Here you'll need to implement the logic for distributing lessons ' while respecting the constraints (group matching, max 2 lessons per student per week, etc.) ' Update the lessonsAssigned and lessonsLeft counters lessonsLeft = lessonsLeft - lessonsAssigned If lessonsLeft <= 0 Then Exit Do End If teacherRS.MoveNext Loop studentRS.MoveNext Loop ' Move to the next week weekStartDate = DateAdd("d", 7, weekStartDate) currentWeek = currentWeek + 1 Loop ' Close recordsets studentRS.Close teacherRS.Close lessonRS.Close vacationRS.Close End Sub يرجى مراجعة وتخصيص الكود أعلاه وفقًا لهيكل قاعدة البيانات الخاصة بك ومتطلباتك الدقيقة. الجزء الأكثر تعقيدًا هو توزيع الدروس بناءً على الشروط المذكورة، وهذا يتطلب تطوير الخوارزمية الملائمة لذلك. إذا واجهتك أي مشكلة خلال عملية التنفيذ، فلا تتردد في طرح الأسئلة.

أهلا بك أخي @حسان12 🙂 تكرما في المرات القادمة أكتب عنوان واضح ومعبر عن مضمون المشاركة .. إتباعا لقواعد المشاركة في المنتدى 🙂 أما بخصوص سؤالك الثاني فطلبك موجود هنا :

ضع أمر Requery لمربع [القيمة] في حدث [عند التغيير] لمربع [الكمية] 🙂

وعليكم السلام ورحمة الله وبركاته.. فعلا أنا استمتعت بقراءة السؤال 😄 مثال ونموذج يحتذى به في طريقة عرض الطلب 👍🏼🙂 وربما ترتيبك لخطوات التحقق في السؤال سيسهل التطبيق للإخوة إن شاء الله ..

هل تم حل مسألتك الأولى ؟؟ وماهي رسالة الخطأ التي تظهر لك ؟

نعم توجد طريقة سهلة .. وهي تحويل الكود لدالة عامة يمكن استخدامها لأكثر من حقل في نفس الوقت .. وهذه هي صيغة الدالة : Function LockField() If InStr(1, Screen.ActiveControl.Value, "Word") > 0 Then Screen.ActiveControl.Locked = True Else Screen.ActiveControl.Locked = False End If End Function ثم تقوم بتحديد جميع الحقول التي ستطبق عليها الكود .. وتذهب لحدث عند التركيذ وتكتب اسم الدالة هكذا : = LockField() كما في الصورة :

نعم استخدم هذا الكود في حدث عند التركيز للحقل المطلوب : If InStr(1, Me.TextBoxName, "Word") > 0 Then Me.TextBoxName.Locked = True Else Me.TextBoxName.Locked = False End If

هذا هو الكود كاملا .. ربما لم تنسخه بأكمله في برنامجك : #If VBA7 Or Win64 Then Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As LongPtr, ByVal wParam As LongPtr, lParam As Any) As LongPtr Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongPtr #Else Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook as long, ByVal ncode as long, ByVal wParam as long, lParam As Any) as long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) as long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA"(ByVal idHook As LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook as long) as long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg as long, ByVal nIDDlgItem as long, ByVal wMsg as long, ByVal wParam as long, ByVal lParam as long) as long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd as long, ByVal lpClassName As String, ByVal nMaxCount as long) as long Private Declare Function GetCurrentThreadId Lib "kernel32" () as long #End If 'Constants to be used in our API functions Private Const EM_SETPASSWORDCHAR = &HCC Private Const WH_CBT = 5 Private Const HCBT_ACTIVATE = 5 Private Const HC_ACTION = 0 #If VBA7 Or Win64 Then Private hHook As LongPtr #Else Private hHook As Long #End If Public Function NewProc(ByVal lngCode As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Dim RetVal Dim strClassName As String Dim lngBuffer As LongPtr If lngCode < HC_ACTION Then NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam) Exit Function End If strClassName = String$(256, " ") lngBuffer = 255 If lngCode = HCBT_ACTIVATE Then RetVal = GetClassName(wParam, strClassName, lngBuffer) If Left$(strClassName, RetVal) = "#32770" Then SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0 End If End If CallNextHookEx hHook, lngCode, wParam, lParam End Function Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, Optional YPos, Optional HelpFile, Optional Context) As String On Error GoTo ExitProperly Dim lngModHwnd As LongPtr Dim lngThreadID As LongPtr lngThreadID = GetCurrentThreadId lngModHwnd = GetModuleHandle(vbNullString) hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID) InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context) UnhookWindowsHookEx hHook ExitProperly: UnhookWindowsHookEx hHook End Function

أخي رضوان @رضوان الجماعي 🙂 أقترح عليك فتح موضوع جديد طازج لكي تأخذ الفكرة حقها من الإهتمام ولفت الإنتباه .. 🙂