Foksh

جهود جميلة منكم أخي الكريم ، واسمحلي بسؤال يدور في ذهني !!
هل تمت التجربة على هذا الكود ؟؟؟؟؟؟؟؟؟؟؟؟؟

وعليكم السلام ورحمة الله وبركاته ..
جرب هذا التعديل  بالاستعلام التالي  :-
SELECT D.Cood, IIf([D].[Percent]*100 <= 60 Or [S].[natio] = 'S', "خارج", [S].[Tans]) AS Expr1 FROM S INNER JOIN D ON S.Cood = D.Cood; جرب الاستعلام وأخبرني بالنتيجة !! 😊

قد يكون الحقل في الجدول نصي وليس رقمي,,
جرب التعديل التالي :-
Private Sub txt_AfterUpdate() Dim selectedYear As Integer selectedYear = Me.txt Me.Filter = "[TOTALSHY] = 0 OR ([yearshy] <> '" & selectedYear & "' AND [TOTALSHY] <> 0)" Me.FilterOn = True End Sub  

تم تعديل اسلوب الدالة من المديول على النحو التالي :-
Function CalculateFridaysSaturdays(monthName As String, Optional baseYear As Integer = 0, Optional dayType As String = "Both") As Variant Dim monthNumber As Integer Dim startDate As Date, endDate As Date Dim fridays As Integer, saturdays As Integer Dim targetYear As Integer monthName = Trim(monthName) Select Case monthName Case "يناير": monthNumber = 1 Case "فبراير": monthNumber = 2 Case "مارس": monthNumber = 3 Case "ابريل": monthNumber = 4 Case "مايو": monthNumber = 5 Case "يونيو": monthNumber = 6 Case "يوليو": monthNumber = 7 Case "اغسطس": monthNumber = 8 Case "سبتمبر": monthNumber = 9 Case "اكتوبر": monthNumber = 10 Case "نوفمبر": monthNumber = 11 Case "ديسمبر": monthNumber = 12 Case Else CalculateFridaysSaturdays = "اسم الشهر غير صحيح" Exit Function End Select If monthNumber >= 10 Then targetYear = year(Date) - 1 ElseIf monthNumber <= 6 Then targetYear = year(Date) Else targetYear = baseYear End If If targetYear < 1900 Or targetYear > 2100 Then CalculateFridaysSaturdays = "السنة غير صحيحة" Exit Function End If fridays = CountWeekdayOccurrences(targetYear, monthNumber, vbFriday) saturdays = CountWeekdayOccurrences(targetYear, monthNumber, vbSaturday) Select Case LCase(dayType) Case "friday": CalculateFridaysSaturdays = fridays Case "saturday": CalculateFridaysSaturdays = saturdays Case Else: CalculateFridaysSaturdays = Array(fridays, saturdays) End Select End Function Function CountWeekdayOccurrences(targetYear As Integer, monthNumber As Integer, targetWeekday As Integer) As Integer Dim startDate As Date, endDate As Date Dim firstDay As Integer, totalDays As Integer Dim count As Integer startDate = DateSerial(targetYear, monthNumber, 1) endDate = DateSerial(targetYear, monthNumber + 1, 0) firstDay = Weekday(startDate) totalDays = endDate - startDate + 1 count = ((totalDays + firstDay - targetWeekday) \ 7) + IIf((firstDay <= targetWeekday), 1, 0) CountWeekdayOccurrences = count End Function  
✅ تحسين قراءة أسماء الأشهر بحيث لا تتأثر بالمسافات الزائدة .
✅ إضافة فحص للسنة لمنع القيم غير المنطقية .
✅ تحسين الأداء باستخدام دالة تقوم بالحساب المباشر .
✅ تجنب الأخطاء عند تمرير قيم غير صحيحة أو عند التعامل مع أسماء الأشهر .
✅ تحديث الاستعلام SQL بحيث يستبعد القيم غير الصالحة (NULL أو الفراغ) .
👌 النتيجة : كود أسرع وأكثر كفاءة ويعمل دون أخطاء غير متوقعة
بهذه الطريقة ، لن تحتاج إلى تغيير الكود يدوياً كل سنة ، وسيتم احتساب القيم المطلوبة تلقائياً !!
 
أما الإستعلام ، فقد تم تعديله لمحاكاة الكود السابق على النحو التالي :-
 
UPDATE data_shr SET gm = CalculateFridaysSaturdays([shr], 0, "Friday"), sbt = CalculateFridaysSaturdays([shr], 0, "Saturday") WHERE shr IN ("يناير", "فبراير", "مارس", "ابريل", "مايو", "يونيو", "اكتوبر", "نوفمبر", "ديسمبر") AND shr IS NOT NULL AND shr <> "";  
 
ايام الغياب 2.accdb
* تم حذف الأجزاء السابقة الغير ضرورية لتلافي ظهور رسائل الأخطاء .

بعد تحميل المرفق من الرابط والإطلاع عليه ،اضطررت الى تعديل أصل الكود بحيث يعمل على النواتين 32 و 64 (النسخة لدي 64 ) ، لتصبح الدالة في المديول كالآتي بعد إزالة التعليقات التوضيحية منها :-
Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As LongPtr, ByVal bInheritHandle As LongPtr, ByVal dwProcessId As LongPtr) 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 LongPtr) 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 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) #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 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) #End If Private Const SEE_MASK_NOCLOSEPROCESS As Long = &H40 Private Const SEE_MASK_DOENVSUBST As Long = &H200 Private Const SEE_MASK_FLAG_NO_UI As Long = &H400 #If VBA7 Then Private Type SHELLEXECUTEINFO cbSize As Long fMask As Long hWnd As LongPtr lpVerb As String lpFile As String lpParameters As String lpDirectory As String nShow As Long hInstApp As LongPtr lpIDList As LongPtr lpClass As String hkeyClass As LongPtr dwHotKey As Long hIcon As LongPtr hProcess As LongPtr End Type #Else Private Type SHELLEXECUTEINFO cbSize As Long fMask As Long hWnd As Long lpVerb As String lpFile As String lpParameters As String lpDirectory As String nShow As Long hInstApp As Long lpIDList As Long lpClass As String hkeyClass As Long dwHotKey As Long hIcon As Long hProcess As Long End Type #End If Public Const INFINITE As Long = &HFFFFFFFF Public Const STILL_ACTIVE As Long = &H103 Public Const PROCESS_HAS_TERMINATED As Long = vbObjectError Or &HDEAD Public Enum AppWinStyle vbHide = 0 vbShowNormal = 1 vbShowMinimized = 2 vbShowMaximized = 3 vbMaximize = 3 vbShowNoActivate = 4 vbShow = 5 vbMinimize = 6 vbShowMinNoActive = 7 vbShowNA = 8 vbRestore = 9 vbShowDefault = 10 End Enum Public Function Shell_n_Wait(ByRef PathName As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus) As Long Const PROCESS_QUERY_INFORMATION = &H400, QS_ALLINPUT = &H4FF, SYNCHRONIZE = &H100000 Dim hProcess As LongPtr, sPath As String If InStr(PathName, "%") = 0 Then sPath = PathName Else SysReAllocStringLen VarPtr(sPath), , ExpandEnvironmentStringsW(StrPtr(PathName)) - 1 ExpandEnvironmentStringsW StrPtr(PathName), StrPtr(sPath), Len(sPath) + 1 End If On Error GoTo ErrorHandler hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or SYNCHRONIZE, False, Shell(sPath, WindowStyle)) On Error GoTo 0 If hProcess Then sPath = vbNullString Do While MsgWaitForMultipleObjects(1, hProcess, False, INFINITE, QS_ALLINPUT) DoEvents Loop GetExitCodeProcess hProcess, Shell_n_Wait CloseHandle hProcess End If Exit Function ErrorHandler: Err.Raise Err.Number, , Err.Description End Function Public Function ShellW(ByRef PathName As String, Optional ByVal WindowStyle As AppWinStyle = vbShowNormal, Optional ByVal Wait As Long) As Long Const MAX_PATH = 260, QS_ALLINPUT = &H4FF, WAIT_OBJECT_0 = &H0 Dim TimedOut As Boolean, nCount As Long, pHandles As LongPtr, RV As Long, SEI As SHELLEXECUTEINFO Err.Clear If LenB(PathName) = 0 Then Exit Function With SEI .cbSize = LenB(SEI) .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_DOENVSUBST Or SEE_MASK_FLAG_NO_UI .nShow = WindowStyle If InStr(PathName, "%") Then SysReAllocStringLen VarPtr(.lpFile), , ExpandEnvironmentStringsW(StrPtr(PathName)) - 1 ExpandEnvironmentStringsW StrPtr(PathName), StrPtr(.lpFile), Len(.lpFile) + 1 Else .lpFile = PathName End If If InStr(.lpFile, "\.") <> 0 Or InStr(.lpFile, ".\") <> 0 Then If Len(.lpFile) < MAX_PATH Then SysReAllocStringLen VarPtr(.lpVerb), , MAX_PATH - 1 If PathCanonicalizeW(StrPtr(.lpVerb), StrPtr(.lpFile)) Then SysReAllocString VarPtr(.lpFile), StrPtr(.lpVerb) End If .lpVerb = vbNullString End If End If SysReAllocString VarPtr(.lpParameters), PathGetArgsW(StrPtr(.lpFile)) If LenB(.lpParameters) Then PathRemoveArgsW StrPtr(.lpFile) If InStr(.lpParameters, """") Then .lpParameters = Replace(.lpParameters, """", """""") End If If ShellExecuteExW(VarPtr(SEI)) Then ShellW = GetProcessId(.hProcess) If Wait Then .lpFile = vbNullString .lpParameters = vbNullString If .hProcess Then nCount = 1 pHandles = VarPtr(.hProcess) End If If Wait > INFINITE Then .hIcon = CreateWaitableTimerW If .hIcon Then nCount = nCount + 1 pHandles = VarPtr(.hIcon) Wait = SetWaitableTimer(.hIcon, CCur(-Wait)) End If End If Do RV = MsgWaitForMultipleObjects(nCount, ByVal pHandles, False, INFINITE, QS_ALLINPUT) If RV < nCount Then If .hIcon Then TimedOut = RV = 0 RV = CloseHandle(.hIcon) End If Err.Clear Exit Do End If DoEvents Loop If Not (TimedOut) Then RV = GetExitCodeProcess(.hProcess, ShellW) Err = PROCESS_HAS_TERMINATED Err.Description = "Exit Code" End If End If If .hProcess Then RV = CloseHandle(.hProcess) End If End With End Function Public Function ShellWS(ByRef Command As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus, Optional ByVal WaitOnReturn As Boolean) As Long Dim ws As Object Set ws = CreateObject("Wscript.Shell") ShellWS = ws.Run(Command, WindowStyle, WaitOnReturn) End Function  
الآن في النموذج الأول th44 ، وبعد نسخ مربع النص str_Text وعنصر الصورة للباركود اليه ، أصبح كود النموذج كالآتي :-
Option Compare Database Option Explicit Private Function ConstQRPath() ConstQRPath = CurrentProject.Path & "\Data\QR_images\" & Me.Key & " - " & "QR_code.png" End Function Private Function ConstBarcodePath() ConstBarcodePath = CurrentProject.Path & "\Data\QR_images\" & Me.Key & " - " & "ID_PDF_417.png" End Function Private Sub CreateQRCode() On Error GoTo ErrorHandler If IsNull(Me.th_Text) Or IsEmpty(Me.th_Text) Or Len(Trim(Nz(Me.th_Text, ""))) = 0 Then Exit Sub End If Dim AppName As String Dim OutputFile As String Dim OutputText As String Dim CommandLine As String AppName = Chr(34) & Application.CurrentProject.Path & "\Data\zint.exe" & Chr(34) OutputText = Chr(34) & Me.th_Text & Chr(34) OutputFile = Chr(34) & ConstQRPath & Chr(34) CommandLine = AppName & " -o " & OutputFile & " --rotate=0 --eci=24 --scale=2 -w 0 --height=100 --barcode=58 -d " & OutputText Shell_n_Wait CommandLine, vbHide Exit Sub ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical, "Error" End Sub Private Sub CreateBarcode() On Error GoTo ErrorHandler If IsNull(Me.str_Text) Or IsEmpty(Me.str_Text) Or Len(Trim(Nz(Me.str_Text, ""))) = 0 Then Exit Sub End If Dim AppName As String Dim OutputFile As String Dim OutputText As String Dim CommandLine As String AppName = Chr(34) & Application.CurrentProject.Path & "\Data\zint.exe" & Chr(34) OutputText = Chr(34) & Me.str_Text & Chr(34) OutputFile = Chr(34) & ConstBarcodePath & Chr(34) CommandLine = AppName & " -o " & OutputFile & " --rotate=0 --eci=24 --binary --barcode=55 --mode=3 -d " & OutputText Shell_n_Wait CommandLine, vbHide Exit Sub ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical, "Error" End Sub Private Sub Form_Current() Call CreateAndDisplayCodes End Sub Sub CreateAndDisplayCodes() On Error GoTo ErrorHandler If IsNull(Me.th_Text) Or IsEmpty(Me.th_Text) Or Len(Trim(Nz(Me.th_Text, ""))) = 0 Then Me.QR_Code.Picture = "" Else Call CreateQRCode Me.QR_Code.Picture = ConstQRPath End If If IsNull(Me.str_Text) Or IsEmpty(Me.str_Text) Or Len(Trim(Nz(Me.str_Text, ""))) = 0 Then Me.ID_PDF_417.Picture = "" Else Call CreateBarcode Me.ID_PDF_417.Picture = ConstBarcodePath End If Exit Sub ErrorHandler: If Err.Number = 2220 Then Me.QR_Code.Picture = "" Me.ID_PDF_417.Picture = "" Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical, "Code generation error" End If Resume Next End Sub Private Sub sdfff_Click() On Error Resume Next DoCmd.OpenForm "thaaer55" Dim RName, FldCriteria As String RName = "rpt_Details" FldCriteria = "[Key]=" & Me![Key] DoCmd.OpenReport RName, acViewNormal, , FldCriteria End Sub  
وهذا الملف بعد التعديل :-
New.zip
 
اخبرنا بالنتيجة 😊 .
 
 
 
 

وعليكم السلام ورحمة الله وبركاته ..
قم بإضافة زر إلى نموذج (مثلاً : btnRestore)
اجعل الكود التالي كتجربة ( بما انك لم تقم بارفاق قاعدتا البيانات للتجربة ) فيحدث عند النقر للزر السابق :-
 
Private Sub btnRestore_Click() Dim dbPath As String Dim backupPath As String Dim fso As Object Dim fd As FileDialog dbPath = CurrentProject.FullName Set fd = Application.FileDialog(3) With fd .Title = "اختر ملف النسخة الاحتياطية" .Filters.Clear .Filters.Add "ملفات Access", "*.accdb;*.mdb" .AllowMultiSelect = False If .Show = -1 Then backupPath = .SelectedItems(1) Else MsgBox "لم يتم تحديد أي ملف!", vbExclamation + vbMsgBoxRight, "إلغاء العملية" Exit Sub End If End With If Dir(backupPath) = "" Then MsgBox "الملف المحدد غير موجود", vbExclamation + vbMsgBoxRight, "خطأ" Exit Sub End If DoCmd.Close acForm, "اسم_النموذج", acSaveYes DoCmd.Close acReport, "اسم_التقرير", acSaveYes DoCmd.Close acTable, "اسم_الجدول", acSaveYes DoCmd.Close acQuery, "اسم_الاستعلام", acSaveYes Set fso = CreateObject("Scripting.FileSystemObject") fso.DeleteFile dbPath, True fso.CopyFile backupPath, dbPath MsgBox "تم استعادة النسخة الاحتياطية بنجاح ! قد تحتاج إعادة تشغيل البرنامج", vbInformation + vbMsgBoxRight, "نجاح" End Sub يجب توافر المكتبة Microsoft Office XX.0 Object Library 

جرب التعديل التالي عله يكون الحل الذي تريده :-
Private Sub NameEmployee_AfterUpdate() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strEmpName As String Dim arrName() As String Dim lastName As String Dim relation As String Dim empID As Integer Dim found As Boolean Dim isFemaleName As Boolean Dim i As Integer Set db = CurrentDb() strEmpName = Me.NameEmployee arrName = Split(strEmpName, " ") If UBound(arrName) >= 2 Then lastName = "" For i = 1 To UBound(arrName) If i > 1 Then lastName = lastName & " " lastName = lastName & arrName(i) Next i Else MsgBox "يجب إدخال الاسم ثلاثيًا على الأقل", vbExclamation + vbMsgBoxRight, "تنبيه" Exit Sub End If isFemaleName = (Right(arrName(0), 1) = "ه" Or Right(arrName(0), 1) = "ة") Set rs = db.OpenRecordset("SELECT IDeMP, NameEmployee FROM DatEmp WHERE IDeMP <> " & Me.IDeMP) found = False Do While Not rs.EOF Dim otherEmpName() As String otherEmpName = Split(rs!NameEmployee, " ") If UBound(otherEmpName) >= 1 Then If arrName(1) = otherEmpName(0) Then Dim matchFound As Boolean matchFound = True If UBound(arrName) >= 2 And UBound(otherEmpName) >= 2 Then If arrName(2) <> otherEmpName(1) Then matchFound = False End If End If If matchFound Then If isFemaleName Then relation = "ابنة" Else relation = "ابن" End If Me.EntityEmployee = relation Me.NameVerificationEmployee = rs!NameEmployee found = True Exit Do End If End If End If rs.MoveNext Loop If Not found Then Me.EntityEmployee = "لا يوجد" Me.NameVerificationEmployee = "فردي" End If rs.Close Set rs = Nothing Set db = Nothing End Sub  

عذراً لمن اتنتظرني بأن أرفق الملف مفتوح المصدر وتأخرت عليه ،،
لن أرفق الأكواد هنا لتعددها وطولها ..
 
GD Uploader.accdb

ما شاء الله عليك ، أبدعت أخي @طاهر اوفيسنا  .
المتبقي بسيط ان شاء الله ، هل هذا طلبك ؟

 
BAR_A(5.3.2025).mdb.zip

لتنفيذ هذه الفكرة ، يمكن اتباع الخطوات التالية :-
1. تحديد مسار حفظ الملفات لكل شعبة
داخل مجلد مشترك على الشبكة ، قم بإنشاء مجلد رئيسي مثل \\Server\Documents\Books\
أنشئ داخله مجلدات لكل شعبة ، مثل :-
 
\\Server\Documents\Books\Accounts 'قسم المحاسبة \\Server\Documents\Books\HR 'قسم شؤون الموظفين وأي اقسام أخرى حسب رغبتك طبعاً 2. إضافة جدول لحفظ بيانات الشعب في قاعدة البيانات
أنشئ جدولاً جديداً باسم tblDepartments على سبيل المثال ، يحتوي على :-
ID (رقم تلقائي)
DeptName (اسم الشعبة)
FolderPath (مسار مجلد الشعبة في الشبكة)
3. تصميم نموذج لاختيار الشعبة وإرسال الملف
أضف نموذجاً جديداً باسم frmSendDocument
أضف مربع قائمة منسدلة (ComboBox) مصدره جدول الشعب (tblDepartments)
أضف زر إرسال يقوم بنسخ الملف إلى مجلد الشعبة المختارة .
4. الكود التالي لنقل الصورة إلى مجلد الشعبة المختارة
عند الضغط على زر الإرسال ، استخدم الكود التالي :-
Private Sub btnSend_Click() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strSourceFile As String Dim strDestinationFile As String Dim strDeptPath As String ' تحديد قاعدة البيانات Set db = CurrentDb Set rs = db.OpenRecordset("SELECT FolderPath FROM tblDepartments WHERE DeptName='" & Me.cboDepartment & "'", dbOpenSnapshot) ' التحقق من العثور على مسار الشعبة If Not rs.EOF Then strDeptPath = rs!FolderPath strSourceFile = Me.txtFilePath ' مسار الملف الأصلي strDestinationFile = strDeptPath & "\" & Dir(strSourceFile) ' نسخ الملف إلى مجلد الشعبة FileCopy strSourceFile, strDestinationFile MsgBox "تم إرسال الصورة إلى " & Me.cboDepartment, vbInformation Else MsgBox "لم يتم العثور على مسار الشعبة", vbCritical End If rs.Close Set rs = Nothing Set db = Nothing End Sub 5. برنامج الاستقبال في الأجهزة المستهدفة
في البرنامج الخاص بكل شعبة ، يمكن عمل نموذج يقوم بفحص المجلد المحدد وعرض الملفات الجديدة .
يمكن استخدام كود VBA لإنشاء زر تحديث يقوم بعرض الملفات الواردة تلقائياً .
6. ملاحظات حول الربط الشبكي
تأكد أن جميع الأجهزة متصلة بالشبكة المحلية (Switch أو Router) .
قم بمشاركة المجلد الرئيسي وإعطاء الصلاحيات المناسبة للمستخدمين .
 
هذا تصور مبدئي للفكرة ، وتختلف آلية التنفيذ حسب طريقة تصميم مشروعك وبرنامجك .

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



Snake.zip

ومشاركة مع والدنا الحبيب @ابوخليل ، 
جرب هذا التعديل مع إمكانية تغيير عدد النسخ التي تريدها ان تبقى ، في الكود التالي :-
 
Private Sub Comannd184_Click() Dim MyFile As String Dim DstFile As String Dim BackupDir As String Dim Syso As Object Dim File As Object Dim BackupFiles As Collection Dim i As Long On Error GoTo ErrH MyFile = CurrentProject.FullName BackupDir = CurrentProject.Path & "\Backup\" DstFile = BackupDir & "Database - " & Format(Date, "yyyy - mm - dd") & ".accde" Set Syso = CreateObject("Scripting.FileSystemObject") Syso.CopyFile MyFile, DstFile Set BackupFiles = New Collection For Each File In Syso.GetFolder(BackupDir).Files If InStr(File.Name, "Database - ") > 0 Then BackupFiles.Add File End If Next File If BackupFiles.Count > 2 Then For i = 1 To BackupFiles.Count - 2 Kill BackupFiles(i).Path Next i End If Name DstFile As DstFile & ".ptc" DBEngine.CompactDatabase DstFile & ".ptc", DstFile Kill DstFile & ".ptc" MsgBox "تم انشاء قاعدة البيانات بنجاح" & vbNewLine & "Database successfully created" & vbNewLine & vbNewLine & "" & "اسم قاعدة البيانات" & vbNewLine & "The name of the database" & vbNewLine & "" & vbNewLine & "Backup-" & Format(Date, "yyyy-mm-dd") & vbNewLine & vbNewLine & "" & "مسار القاعدة الجديدة" & vbNewLine & "Path of the new rule" & vbNewLine & "" & vbNewLine & DstFile, vbMsgBoxRight + vbOKOnly, "emphasis" & "/" & "تاكيد" Exit Sub ErrH: MsgBox "خطأ: " & Err.Description, vbCritical End Sub  
ملفك بعد التعديل 
New.zip

بإذن الله ، قريباً جداً مهندسنا الغالي 

أخي @ناقل ، ما رأيك بهذه الفكرة ؟
BackLight3.accdb

للأسف المشكلة كانت في متغير تافه هو اللي عمل هذه المشكلة 🤣 ، وتم التعامل معه 🤠

 
LanguageCheck V 2.5.accdb

تفضل فكرتي المتواضعة ، حيث سيتم أولاً تحميل أسماء الاستعلامات في الليست بوكس ، وانت تختار ما تريده ، ثم انقر الزر للتصدير :-
Private Sub Export_Selected_Queries() Dim xlApp As Object, xlWorkbook As Object, xlWorksheet As Object Dim db As DAO.Database, rs As DAO.Recordset Dim sheetIndex As Integer, colIndex As Integer, rowIndex As Integer Dim filePath As String, queryName As String Dim i As Variant filePath = Application.CurrentProject.Path & "\تقرير_الاكسيل.xlsx" If Me.Que_List.ItemsSelected.Count = 0 Then MsgBox "يرجى تحديد استعلام واحد على الأقل قبل التصدير", vbExclamation + vbMsgBoxRight, "خطأ" Exit Sub End If Set xlApp = CreateObject("Excel.Application") xlApp.Visible = True Set xlWorkbook = xlApp.Workbooks.Add Set db = CurrentDb sheetIndex = 1 For Each i In Me.Que_List.ItemsSelected queryName = Trim(Me.Que_List.ItemData(i)) Set rs = db.OpenRecordset(queryName, dbOpenSnapshot) If sheetIndex <= xlWorkbook.Sheets.Count Then Set xlWorksheet = xlWorkbook.Sheets(sheetIndex) Else Set xlWorksheet = xlWorkbook.Sheets.Add End If xlWorksheet.Name = queryName colIndex = 1 With xlWorksheet For Each fld In rs.Fields .Cells(1, colIndex).Value = fld.Name .Cells(1, colIndex).Font.Bold = True colIndex = colIndex + 1 Next fld rowIndex = 2 Do While Not rs.EOF colIndex = 1 For Each fld In rs.Fields .Cells(rowIndex, colIndex).Value = fld.Value colIndex = colIndex + 1 Next fld rowIndex = rowIndex + 1 rs.MoveNext Loop End With rs.Close sheetIndex = sheetIndex + 1 Next i xlWorkbook.SaveAs filePath xlWorkbook.Close xlApp.Quit On Error Resume Next Set rs = Nothing Set db = Nothing Set xlWorksheet = Nothing Set xlWorkbook = Nothing Set xlApp = Nothing On Error GoTo 0 MsgBox "تم تصدير البيانات بنجاح", vbInformation + vbMsgBoxRight, "نجاح العملية" End Sub  
test.accdb
 
 

ومشاركة مع الأستاذ @عبد اللطيف سلوم ، هذه فكرتي ، الدالة التالية
 
Function ToggleAMPM(timeValue As Date) As Date If Format(timeValue, "AM/PM") = "AM" Then ToggleAMPM = DateAdd("h", 12, timeValue) Else ToggleAMPM = DateAdd("h", -12, timeValue) End If End Function  
time.accdb

وعليكم السلام ورحمة الله وبركاته ،،
أخي الكريم بدايةً لا تستغرب من عدم الرد على موضوعك والتجاوب معه . فلا اعتقد انه يوجد حاجة لارسال المشروع كاملاً ، وقد يكفي ارسال ما له علاقة من مكونات تسهيلاً على من يحاول تقديم المساعدة ولفهم المشكلة بشكل أوضح وأبسط وأسرع .
ثانياً وحتى لا أطـيـل عليك ، مشروعك يحتاج الى إعادة الهيكلة والبناء ..
ثالثاً لماذا اعتمدت على أن يكون الحقل "idproduct" في الجدول "tabsu" مفتاح أساسي مع العلم أنه ليس له اي علاقة مع اي حقل ؟؟؟؟
والأصل هو ان يكون هذا الحقل - والذي اعتقد انه يمثل رقم المنتج - مفتاح أساسي فقط في جدول الأصناف أو المنتجات "product" ، ومن هناك يكون له علاقات مع ما يختص به من توابع .
حاول إلغاء المفتاح الأساسي عن هذا الحقل واعتقد ان مشكلتك سوف تنتهي . فالأصل في جسم الفاتورة هو ان تكون مرتبطة برقم الفاتورة بين رأس الفاتورة وجسم الفاتورة ( إن جاز التعبير ) .

هذا سيعود عليك بمنافع ومضار في نفس الوقت ,,
برأيي ان كثرة استخدام فكرة الضغط والإصلاح قد يؤدي الى تلف او فقدان البيانات أو قاعدة البيانات بشكل كامل . لذا عليك توظيف الفكرة بحيث تكون محكومة بمرة واحدة على الأقل في اليوم .
طبعاً هو يعتمد ايضاً على ما اذا كانت قاعدة البيانات مقسمة أم لا ,,,
جرب هذا الكود لضغط وإصلاح قاعدة البيانات الغير مقسمة ,,
Public Function compactDb(ByVal mydb As String, ByVal mypass As String, Optional openIt As Boolean = False) Dim f As Integer Dim filenoext As String, extension As String, Access As String Access = """" & SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE""" filenoext = Left(mydb, InStrRev(mydb, ".")) extension = Right(mydb, Len(mydb) - InStrRev(mydb, ".")) f = FreeFile Open CurrentProject.Path & "\compact.bat" For Output As f Print #f, "CHCP 1256" Print #f, ":checkldb1" Print #f, "if exist """ & filenoext & "l" & extension & """ goto checkldb1" Print #f, Access & " """ & mydb & """" & mypass & " /compact" If openIt Then Print #f, ":checkldb2" Print #f, "if exist """ & filenoext & "l" & extension & """ goto checkldb2" Print #f, Access & " """ & mydb & """" Else Print #f, "del ""%~f0""" End If Close f End Function Public Function CopactMyDb() On Error Resume Next Dim Mypath As String Mypath = CurrentProject.Path & "\" & CurrentProject.Name Call compactDb(Mypath, "", True) Shell """" & Left(Mypath, InStrRev(Mypath, "\")) & "\compact.bat""", 0 DoCmd.Quit acQuitSaveAll End Function الإستدعاء سيكون في الزر في حدث عند النقر كما يلي :-
CopactMyDb  

وعليكم السلام ورحمة الله وبركاته ،
إن كنت من متابعي ومنتسبي جروب الواتس أب ؛ فقد تمت الإجابة عن هذا السؤال سابقاً ..
 
مثال بسيط
Main (1).accdb
 

جرب
On Error GoTo hoh DoCmd.Save DoCmd.GoToRecord , , acNewRec Me.Instructor_ID.SetFocus hoh: If Err.Number = 2105 Then MsgBox "سجل مكرر ! لا يمكنك إدخال نفس البيانات مرتين", vbExclamation + vbMsgBoxRight, "تنبيه" Cancel = True Else MsgBox "حدث خطأ", vbCritical + vbMsgBoxRight, "خطأ" End If  

وعليكم السلام ورحمة الله وبركاته
Null  

وعليكم السلام ورحمة الله وبركاته ,,
 
في مديول عام ، الصق هذا الكود :-
Option Compare Database Option Explicit Public pdfPathGlobal As String Public rptNameGlobal As String Public Sub ExportReportToPDF(rptName As String, fileName As String) On Error Resume Next Dim dialog As FileDialog Dim pdfPath As String Dim db As DAO.Database Set db = CurrentDb Set dialog = Application.FileDialog(msoFileDialogSaveAs) With dialog .title = "حفظ التقرير كملف PDF" .InitialFileName = fileName & ".pdf" .InitialView = msoFileDialogViewDetails If .Show = -1 Then pdfPath = .SelectedItems(1) If LCase(Right(pdfPath, 4)) <> ".pdf" Then pdfPath = pdfPath & ".pdf" End If DoCmd.OutputTo acOutputReport, rptName, acFormatPDF, pdfPath, False MsgBox "تم تصدير التقرير بنجاح كملف PDF", vbInformation + vbMsgBoxRight, "نجاح التصدير" Else db.Execute "DELETE FROM Tbl_Temp", dbFailOnError MsgBox "تم إلغاء عملية التصدير", vbInformation + vbMsgBoxRight, "إلغاء التصدير" DoCmd.Close acReport, rptName End If End With Set dialog = Nothing End Sub  
ثم في زر جديد كما في المرفق ( تستطيع تغييره كما تريد ) / الصق الاستدعاء كالتالي :-
Private Sub Bth_PDF_Click() Dim rptName As String Dim fileName As String If IsNull(Me.x_tkrer) Or Trim(Me.x_tkrer) = "" Then MsgBox "يرجى اختيار اسم التقرير قبل التصدير.", vbExclamation + vbMsgBoxRight, "" Exit Sub End If Select Case Me.x_tkrer Case "كشف الحوافز" rptName = "rep1" Case "استمارة الصرف" rptName = "rep50" Case Else MsgBox "ليس هناك تقرير بهذا الإسم", vbExclamation + vbMsgBoxRight, "" Exit Sub End Select fileName = Me.x_tkrer DoCmd.OpenReport rptName, acViewPreview ExportReportToPDF rptName, fileName End Sub وتستطيع إضافة أكثر من تقرير كما تريد مع استعمال الدالة Case بدلاً من IF الشرطية ...
* ملاحظة ,, قم بإضافة المكتبة التالية حسب اصدار الأوفيس لديك :-

وهذه فكرتي ، تفضل :-
برنامج الحوافز.accdb
 

وعليكم السلام ورحمة الله تعالى وبركاته ،،
تعديل بسيط في جملة If لتشمل ثلاث حالات
Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer) Dim x, y, rid As Single x = Me.ruslt.Left + Me.ruslt.Width / 2 y = Me.ruslt.Top + Me.ruslt.Height / 2 rid = Me.ruslt.Width / 2 If Me.ruslt = "(غ)" Or Me.ruslt = "له برنامج علاجي" Or Me.ruslt = "لها برنامج علاجي" Then Me.FillColor = RGB(238, 198, 211) Me.FillStyle = 0 Me.Circle (x, y), rid, RGB(256, 0, 0), , , 0.2 End If End Sub  
جرب وأخبرني بالنتيجة 

وعليكم السلام ورحمة الله وبركاته أخي @بوكفوس عبدالسلام ..
بما انك تصر على استخدام مسميات عربية وهذا يعني انك مصمم على المضي في طريق عدم اكتساب المعلومة الصحيحة ..
اجعل مصدر كل تقرير = الجدول أو الحقول التي تريدها مع تحديد الشرط بحيث يكون الشرط واقع ضمن تحديد حقل الرقم = مربع النص Texte256 وعلى حسب ما فهمت هو حقل الرقم للسجل ، وإلا فعدل الشرط بتغيير مربع النص والحقل للمفتاح الأساسي .
 
على العموم هذه فكرتي والتي تجاري فكرتك في انشاء قاعدة البيانات غير الصحيحة :-
Hand.zip