Foksh

وعليكم السلام ورحمة الله وبركاته .. راجع هذا الموضوع ، عله يفيدك ، مع العلم أن الأداة قيد التطوير والتحديث

جميل جداً .. ستتم المتابعة

ولأجمل هو تشريفكم لنا بملاحظاتكم ومروركم العطر .. بارك الله فيكم ، وهي ما زالت في طور التحديث كلامك سليم ، وكانت من ضمن الاحتمالات التي مررت بها ، ولكن لله الحمد تم إضافة التعديل وأصبحت النتيجة لأول تجربة لك = '=================================================== ' API Code Converter for Dual Compatibility (32-bit & 64-bit) ' Developed By Foksh (Officena.Net) ' Generated on: 2025-05-29 10:34:09 ' Tool version: v1.3 '=================================================== #If VBA7 And Win64 Then ' 64-bit declarations Public Declare PtrSafe Function CopyFile Lib "kernel32" Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long #Else ' 32-bit declarations Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA"(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long)As Long #End If لمتابعتكم إن كانت النتيجة صحيحة .. جزاااكم الله خيراً تم الاطلاع واكتساب الفائدة . والتجربة الثانية ، بعد التحديثات الحالية كانت نتيجتها = '=================================================== ' API Code Converter for Dual Compatibility (32-bit & 64-bit) ' Developed By Foksh (Officena.Net) ' Generated on: 2025-05-29 10:37:15 ' Tool version: v1.3 '=================================================== Private Const KEYEVENTF_KEYUP = &H2 ' Get the current state of the NumLock key Function GetNumLockKey() As Boolean GetNumLockKey = GetKeyState(vbKeyNumlock) End Function Sub SetNumLockKey(ByVal newState As Boolean) ' if the current state must be changed If CBool(GetKeyState(vbKeyNumlock)) <> newState Then ' programmatically press and release the NumLock key keybd_event vbKeyNumlock, 0, 0, 0 keybd_event vbKeyNumlock, 0, KEYEVENTF_KEYUP, 0 End If End Sub #If VBA7 And Win64 Then ' 64-bit declarations Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, _ ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Long #Else ' 32-bit declarations Private Declare Sub keybd_event Lib "user32"(ByVal bVk As Byte, _ ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Declare Function GetKeyState Lib "user32"(ByVal nVirtKey As Long)As _ Long #End If هل توافق المطلوب أم لا ؟؟ هذه النقطة كنت قد سهوت عنها من كثرة التجارب ، وكنت اعتمد القص بدلاً من النسخ 😅 . سيتم اعادة الكود للنسخ بدلاً من القص .

📌 مقدمة عن الأداة :- أقدم لكم أداة متقدمة لتحويل أكواد API في آكسيس من الإصدارات القديمة والحديثة ، لتكون متوافقة مع أنظمة 64-bit مع الحفاظ على التوافق مع أنظمة 32-bit . هذه الأداة تم تطويرها خصيصاً لمطوري ومبرمجي قواعد البيانات الذين يعانون من مشاكل التوافق عند الترقية إلى إصدارات أوفيس 64-bit . 🎯 المشكلة التي تحلها الأداة :- مع إصدار أوفيس 64-bit ، تغيرت بنية المؤشرات والأنواع الخاصة بمناولة النوافذ (Handles) من Long (32-bit) إلى LongPtr (64-bit) . هذا التغيير جعل معظم إعلانات API القديمة غير صالحة للعمل على الإصدارات الجديدة ، مما يتطلب تعديلها يدوياً لها . ما الجديد في التحديث الجديد ؟ ميزات الأداة الرئيسية والمحدثة :- تحويل تلقائي للإعلانات :- تقوم بتحويل إعلانات API من صيغة 32-bit إلى صيغة مزدوجة ( 32 و 64 ) متوافقة مع كلا النظامين . دعم أنواع البيانات الخاصة :- تدعم الأنواع المعرفة من المستخدم (User-Defined Types) مثل RECT , POINTAPI وغيرها . تحليل ذكي للكود :- تتعرف على المتغيرات التي تحتاج تحويلاً وتعدلها تلقائياً . حفظ التوافق مع الإصدارات القديمة :- تحافظ على عمل الكود على أنظمة 32-bit أثناء إضافة دعم 64-bit . واجهة سهلة الاستخدام :- توفر واجهة بسيطة لتحويل الأكواد بنقرة واحدة . كيف تعمل الأداة ؟ تعتمد الأداة على عدة خطوات ذكية لتحليل الكود وإجراء التحويل :- 1. تحليل الإعلانات :- تفحص كل إعلانات API لتحديد ما إذا كانت تحتاج إلى تعديل أم لا !!! 2. تحديد أنواع البيانات :- تتعرف على المتغيرات من نوع Long التي تمثل مؤشرات أو مقابض (Handles) بشكل تلقائي وذكي . 3. إنشاء كود مشروط :- تولد كوداً يستخدم التعليمة الشرطية #If VBA7 And Win64 Then للتفريق بين النظامين . 4. الحفاظ على الهيكل الأصلي :- تحافظ على التعليقات والتنسيق الأصلي للكود قدر الإمكان . ( باللغة الإنجليزية حالياً) . أنواع API التي تتعامل معها الأداة :- تتعامل الأداة مع مجموعة واسعة من إعلانات API ، بما في ذلك :- إدارة النوافذ (User32.dll) FindWindow, GetWindow, SetWindowPos SendMessage, PostMessage GetWindowRect, GetWindowText إدارة الذاكرة والعمليات (Kernel32.dll) VirtualAlloc, VirtualFree OpenProcess, CreateProcess GetModuleHandle, GetProcAddress إدارة التسجيل (Advapi32.dll) RegOpenKey, RegCreateKey RegQueryValue, RegSetValue إدارة واجهة المستخدم CreateDC, CreateCompatibleDC SelectObject, DeleteObject الخصائص الفنية للأداة :- الدقة في التحويل :- تتعرف الأداة على السياقات المختلفة للمتغيرات من نوع Long لتحديد ما إذا كانت تمثل مقابض تحتاج للتحويل . دعم اللغات :- تدعم الواجهة اللغتين العربية والإنجليزية . التحقق من الأخطاء :- تحتوي على آلية للتحقق من الأخطاء المحتملة أثناء التحويل . التعامل مع الاستثناءات :- تتعرف على الدوال التي لا تحتاج للتحويل مثل GetVersion وGetTickCount .

وعليكم السلام ورحمة الله وبركاته .. احذف بيانات الجدول ( Tbl_degree_Detail ) أولاً ، ثم عدل الاستعلام في زر الاعداد الى التالي :- DoCmd.RunSQL "INSERT INTO Tbl_degree_Detail ( draseid, draseDate, Stu_card, Elsaf, madaNum, madaName, ramz, ramz2, Stugalos ) " & vbCrLf & _ "SELECT [forms]![frm_DraseIN]![drase] AS drs, [forms]![frm_DraseIN]![Text1] AS drsdt, Tbl_student.Stucard, Tbl_student.alsaf_Id, Tbl_materil.materil_id, Tbl_materil.materil, Tbl_materil_Detail.rmz, Tbl_materil_Detail.rmz2, Tbl_student.Stugalos " & vbCrLf & _ "FROM Tbl_materil INNER JOIN ((Tbl_saf INNER JOIN Tbl_student ON Tbl_saf.saf_id = Tbl_student.alsaf_Id) INNER JOIN Tbl_materil_Detail ON Tbl_saf.saf_id = Tbl_materil_Detail.saf_No) ON Tbl_materil.materil_id = Tbl_materil_Detail.mat_NO;" طبعاً وللتأكيد بإخبارك بضرورة إضافة نفس الحقل من نفس النوع في الحدول المستهدف ، واعتقدت بعدم ذكرها أنك تعلم ذلك جرب وأخبرني بالنتيجة .. 😅

💥 الإداة بواجهتين ( عربي - انجليزي ) والرسائل والردود حسب كل لغة Code Converter x64.zip Code Converter x32.zip طبعاً ، أتمنى ممن يرغب بتجربة الأداة بأول إصدار لها ، أن يزودني بالنتيجة التي قام بها على الكود ، بحيث :- ينشر في رده الكود الأصل ( الذي قام بتجربته ) ، والكود الناتج ( بعد تحويله من الأداة ) لتعم الفائدة ولمعرفة الأخطاء التي قد تحدث ( ولا شك أن الأداة تحتوي أخطاء كثيرة ، ولكن لإجراءاتكم بالإفادة ) . إن كان يملك الكود الصحيح والمنطقي ( الذي يعمل على النواتين ) ، فشاكراً له تزويدنا به للمقارنة . Code Converter x32.zip Code Converter x64.zip

نعم فهمتك على ما أعتقد ، انت تريد زر الطباعة أن يعمل على أي تقرير تم فتحه ( في الوقت الحالي ) ، صحيح ؟؟ سنحاول الإستفادة من المتغير العام :- Public namerpts As String بحيث نمرر لزر التصدير اسم التقرير الحالي بشكل ديناميكي . وعليه فيصبح الكود لزر التصدير كالتالي :- Dim stDocName As String, xx As String, strPathAndfile As String Dim reportDate As Variant stDocName = namerpts On Error Resume Next reportDate = [Reports]![namerpts]![DATE] On Error GoTo 0 If IsNull(reportDate) Or Not IsDate(reportDate) Then xx = stDocName & "-" & Format(DATE, "dd_mm_yyyy") Else xx = stDocName & "-" & Format(reportDate, "dd_mm_yyyy") End If strPathAndfile = CurrentProject.Path & "\" DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, strPathAndfile & xx & ".pdf", True لم أقم بتصعيد الموضوع بكود طويل ، واقتصرت على الكود السابق لسهولته وفهمه بسهولة ,, تفضل الملف بعد التعديل ، جربه وأخبرني بالنتيجة . ملاحظة .. يفضل أن يكون اسم الحقل الخاص بالتاريخ متساوي في كل التقارير ، لتلافي تطوير الكود . حفظ بصغة PDF.zip

حفظ بصغة PDF.zip

افتح هذا الملف من جهازي ، بعد ضبط وتغيير حجم الخط ومساحة مربع النص 0 العرض ) ، ثم تصدير التقرير .. علماً أن الخط Sultan Medium ليس موجوداً على جهازي . rptTransfer_BEA_Ccp-19_01_2025.pdf

اخي الكريم ، المشكلة قد تكون بحجم الخط ، حاول إما تكبير مربع النص ، أو تصغير حجم الخط !!!

وعليكم السلام ورحمة الله وبركاته ،،، أخي العزيز طاهر ، الخطأ عندك في السطر التالي xx = stDocName & "-" & Format([TxtMonth], "dd_mm_yyyy") ويجب أن يكون كالآتي :- xx = stDocName & "-" & Format([Reports]![rptTransfer_BEA_Ccp]![DATE], "dd_mm_yyyy") السبب طبعاً انك تريد إضافة التاريخ حسب قيمة مربع نص غير موجود إلا في النموذج المخصص لشريط الطباعة prin . لذا فأن التقرير لا يتم تصديره الى ملف PDF كما تريد . ولديك خطأ متكرر في طريقة تصميمك ، وهي :- أن الاسم DATE لمربع نص = خاطئ ❌ ، وغير صحيح وقد يسبب لك مشاكل كبيرة ، والأصل الإبتعاد عن الأسماء المحجوزة لآكسيس .

تضدق أخي عمر أني كنت أبحث في اتجاه آخر ( عدد الفواتير ) لاحظ آخر وقوفي عند هذا التعديل :- Public Function ProcessFIFO() On Error GoTo HandleError Dim db As DAO.Database Dim tdf As DAO.TableDef Dim tableExists As Boolean Dim SQL As String Dim rst As DAO.Recordset Dim i As Long Dim currentBatch As Variant Dim newBatch As Variant Dim remainingSale As Double Dim deductQty As Double Dim profit As Double Dim salePrice As Double Dim purchasePrice As Double Dim salesInvoiceCount As Long Dim lastSalesInvID As String Dim specificItemSalesCount As Long Dim targetItemCode As Long specificItemSalesCount = 0 targetItemCode = 19 salesInvoiceCount = 0 lastSalesInvID = "" Set db = CurrentDb() tableExists = False For Each tdf In db.TableDefs If tdf.Name = "TblFifoStockLocal" Then tableExists = True Exit For End If Next tdf If Not tableExists Then SQL = "CREATE TABLE TblFifoStockLocal (" & _ "ID AUTOINCREMENT PRIMARY KEY, " & _ "InvID TEXT(50), " & _ "InvType LONG, " & _ "InvTypeName TEXT(50), " & _ "ItemCode LONG, " & _ "ItemName TEXT(100), " & _ "PurchasedQty Double, " & _ "SoldQty Double, " & _ "ReturnPurchasedQty Double, " & _ "ReturnSoldQty Double, " & _ "ActualBalance Double, " & _ "PurchasePrice DOUBLE, " & _ "SalePrice DOUBLE, " & _ "Profit DOUBLE, " & _ "CostOfGoodsSold DOUBLE, " & _ "TotalOfGoodsPurchased DOUBLE, " & _ "TransactionDate DATETIME);" db.Execute SQL, dbFailOnError db.TableDefs.Refresh Set tdf = db.TableDefs("TblFifoStockLocal") With tdf.Fields("ID") .Properties("Caption") = "SN" End With With tdf.Fields("InvID") .Properties("Caption") = "معرف الفاتورة" End With With tdf.Fields("InvType") .Properties("Caption") = "نوع الفاتورة" End With With tdf.Fields("InvTypeName") .Properties("Caption") = "اسم نوع الفاتورة" End With With tdf.Fields("ItemCode") .Properties("Caption") = "رمز الصنف" End With With tdf.Fields("ItemName") .Properties("Caption") = "اسم الصنف" End With With tdf.Fields("PurchasedQty") .Properties("Caption") = "الكمية المشتراة" End With With tdf.Fields("SoldQty") .Properties("Caption") = "الكمية المباعة" End With With tdf.Fields("ReturnPurchasedQty") .Properties("Caption") = "كمية مرتجع المشتريات" End With With tdf.Fields("ReturnSoldQty") .Properties("Caption") = "كمية مرتجع المبيعات" End With With tdf.Fields("ActualBalance") .Properties("Caption") = "الرصيد الفعلي" End With With tdf.Fields("PurchasePrice") .Properties("Caption") = "سعر الشراء" End With With tdf.Fields("SalePrice") .Properties("Caption") = "سعر البيع" End With With tdf.Fields("Profit") .Properties("Caption") = "الربح" End With With tdf.Fields("CostOfGoodsSold") .Properties("Caption") = "تكلفة البضاعة المباعة" End With With tdf.Fields("TotalOfGoodsPurchased") .Properties("Caption") = "إجمالي البضاعة المشتراة" End With With tdf.Fields("TransactionDate") .Properties("Caption") = "تاريخ العملية" End With Else db.Execute "DELETE FROM TblFifoStockLocal;", dbFailOnError End If tableExists = False For Each tdf In db.TableDefs If tdf.Name = "TblFifoRemaining" Then tableExists = True Exit For End If Next tdf If Not tableExists Then SQL = "CREATE TABLE TblFifoRemaining (" & _ "ID AUTOINCREMENT PRIMARY KEY, " & _ "ItemCode LONG, " & _ "InvID DOUBLE, " & _ "InvNo TEXT(50), " & _ "ItemName TEXT(100), " & _ "InvDate DATETIME, " & _ "RemainingQty Double, " & _ "PurchasePrice DOUBLE, " & _ "TotalCost DOUBLE);" db.Execute SQL, dbFailOnError db.TableDefs.Refresh Set tdf = db.TableDefs("TblFifoRemaining") With tdf.Fields("ID") .Properties("Caption") = "SN" End With With tdf.Fields("ItemCode") .Properties("Caption") = "رمز الصنف" End With With tdf.Fields("InvID") .Properties("Caption") = "معرف الفاتورة" End With With tdf.Fields("InvNo") .Properties("Caption") = "رقم الفاتورة" End With With tdf.Fields("ItemName") .Properties("Caption") = "اسم الصنف" End With With tdf.Fields("InvDate") .Properties("Caption") = "تاريخ الفاتورة" End With With tdf.Fields("RemainingQty") .Properties("Caption") = "الكمية المتبقية" End With With tdf.Fields("PurchasePrice") .Properties("Caption") = "سعر الشراء" End With With tdf.Fields("TotalCost") .Properties("Caption") = "التكلفة الإجمالية" End With Else db.Execute "DELETE FROM TblFifoRemaining;", dbFailOnError End If SQL = "SELECT TblInvHead.InvID, TblInvHead.InvDate, TblInvHead.InvNo, " & _ "TblInvHead.InvType, TblInvType.InvTypeName, TblInvDetails.ID, " & _ "TblInvDetails.LItemID, TblItems.ItemName, " & _ "TblInvDetails.Qty, TblInvDetails.PaPrice, TblInvDetails.SaPrice " & _ "FROM TblInvType INNER JOIN (TblInvHead INNER JOIN " & _ "(TblItems INNER JOIN TblInvDetails ON TblItems.ItemCode = TblInvDetails.LItemID) " & _ "ON TblInvHead.InvID = TblInvDetails.LInvID) " & _ "ON TblInvType.InvTypeID = TblInvHead.InvType " & _ "ORDER BY TblInvHead.InvDate, TblInvHead.InvType, TblInvDetails.LItemID;" Set rst = db.OpenRecordset(SQL, dbOpenDynaset) Dim fifoList As New Collection Dim dictBalance As Object Set dictBalance = CreateObject("Scripting.Dictionary") Do While Not rst.EOF If Not IsNull(rst!Qty) And rst!Qty > 0 Then Select Case rst!InvType Case 1 If Not IsNull(rst!LitemID) Then newBatch = Array(rst!LitemID, rst!ItemName, rst!Qty, rst!PaPrice, rst!InvDate, rst!InvID, rst!InvNo) fifoList.Add newBatch If Not dictBalance.Exists(rst!LitemID) Then dictBalance.Add rst!LitemID, 0 End If dictBalance(rst!LitemID) = dictBalance(rst!LitemID) + rst!Qty db.Execute "INSERT INTO TblFifoStockLocal (InvID,InvType,InvTypeName,ItemCode,ItemName," & _ "PurchasedQty,ActualBalance,PurchasePrice,TransactionDate) VALUES ('" & _ rst!InvID & "',1,'مشتريات'," & rst!LitemID & ",'" & _ Replace(rst!ItemName, "'", "''") & "'," & rst!Qty & "," & _ dictBalance(rst!LitemID) & "," & rst!PaPrice & ",#" & _ Format(rst!InvDate, "mm/dd/yyyy") & "#)", dbFailOnError End If Case 2 If lastSalesInvID <> rst!InvID Then salesInvoiceCount = salesInvoiceCount + 1 lastSalesInvID = rst!InvID End If remainingSale = rst!Qty For i = 1 To fifoList.Count If fifoList(i)(0) = rst!LitemID Then currentBatch = fifoList(i) If currentBatch(2) > 0 Then deductQty = IIf(currentBatch(2) >= remainingSale, remainingSale, currentBatch(2)) salePrice = Nz(rst!SaPrice, 0) purchasePrice = Nz(currentBatch(3), 0) profit = (salePrice - purchasePrice) * deductQty currentBatch(2) = currentBatch(2) - deductQty If Not dictBalance.Exists(rst!LitemID) Then dictBalance.Add rst!LitemID, 0 End If dictBalance(rst!LitemID) = dictBalance(rst!LitemID) - deductQty db.Execute "INSERT INTO TblFifoStockLocal (InvID,InvType,InvTypeName,ItemCode," & _ "ItemName,SoldQty,ActualBalance,PurchasePrice,SalePrice,Profit," & _ "TransactionDate) VALUES ('" & rst!InvID & "',2,'مبيعات'," & _ rst!LitemID & ",'" & Replace(rst!ItemName, "'", "''") & "'," & _ deductQty & "," & dictBalance(rst!LitemID) & "," & _ purchasePrice & "," & salePrice & "," & profit & ",#" & _ Format(rst!InvDate, "mm/dd/yyyy") & "#)", dbFailOnError remainingSale = remainingSale - deductQty If remainingSale = 0 Then Exit For End If End If Next i Case 3 If Not dictBalance.Exists(rst!LitemID) Then dictBalance.Add rst!LitemID, 0 End If dictBalance(rst!LitemID) = dictBalance(rst!LitemID) - rst!Qty db.Execute "INSERT INTO TblFifoStockLocal (InvID,InvType,InvTypeName,ItemCode,ItemName," & _ "ReturnPurchasedQty,ActualBalance,PurchasePrice,TransactionDate) VALUES ('" & _ rst!InvID & "',3,'مرتجع مشتريات'," & rst!LitemID & ",'" & _ Replace(rst!ItemName, "'", "''") & "'," & rst!Qty & "," & _ dictBalance(rst!LitemID) & "," & rst!PaPrice & ",#" & _ Format(rst!InvDate, "mm/dd/yyyy") & "#)", dbFailOnError Case 4 If Not dictBalance.Exists(rst!LitemID) Then dictBalance.Add rst!LitemID, 0 End If dictBalance(rst!LitemID) = dictBalance(rst!LitemID) + rst!Qty db.Execute "INSERT INTO TblFifoStockLocal (InvID,InvType,InvTypeName,ItemCode,ItemName," & _ "ReturnSoldQty,ActualBalance,SalePrice,TransactionDate) VALUES ('" & _ rst!InvID & "',4,'مرتجع مبيعات'," & rst!LitemID & ",'" & _ Replace(rst!ItemName, "'", "''") & "'," & rst!Qty & "," & _ dictBalance(rst!LitemID) & "," & rst!SaPrice & ",#" & _ Format(rst!InvDate, "mm/dd/yyyy") & "#)", dbFailOnError End Select End If rst.MoveNext Loop If fifoList.Count > 0 Then Dim insertCount As Long insertCount = 0 For i = 1 To fifoList.Count currentBatch = fifoList(i) If IsArray(currentBatch) Then If IsNumeric(currentBatch(2)) Then If CDbl(currentBatch(2)) > 0 Then db.Execute "INSERT INTO TblFifoRemaining (ItemCode,InvID,InvNo,ItemName,InvDate," & _ "RemainingQty,PurchasePrice,TotalCost) VALUES (" & _ currentBatch(0) & "," & currentBatch(5) & ",'" & currentBatch(6) & "','" & _ Replace(currentBatch(1), "'", "''") & "',#" & Format(currentBatch(4), "mm/dd/yyyy") & "#," & _ currentBatch(2) & "," & currentBatch(3) & "," & (currentBatch(2) * currentBatch(3)) & ")", dbFailOnError insertCount = insertCount + 1 End If End If End If Next i End If MsgBox "إجمالي عدد فواتير المبيعات: " & salesInvoiceCount, vbInformation + vbMsgBoxRight, "" rst.Close Set rst = Nothing Set db = Nothing Exit Function HandleError: MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight, "" If Not rst Is Nothing Then rst.Close Set rst = Nothing Set db = Nothing End Function طبعاً كنت حذفت أجزاء كانت بتأخر شغل الإحصاء ، ولكني للأسف لم استدل الى ما هو سبب المشكلة ,, ( البحث في اتجاه مخالف جعلني أدور في حلقة مفرغة )

وعليكم السلام ورحمة الله وبركاته .. في فكرتك هذه الجأ الى انشاء جدول و نموذج مخصصين فقط لضبط الشعار وترويسة التقارير والنماذج ... إلخ . بحيث أقوم بإنشاء عادة 5 حقول داخل الجدول هذا = Logo و Repo_Header و Repo Footer و Frm_Header و Frm_Footer .... حسب الحاجة طبعاً ، وجميعها من نوع نصي . وفي النموذج اجعل لكل حقل زر اختيار صورة يتم نسخها في مجلد خاص داخل مجلدات المشروع ويتم تحديد مسارها داخل الجدول فقط . وعليه وكما أشار معلمنا الفاضل جعفر والأستاذ عمر يتم تحديد مسار مصدر عنصر الصورة مستخدماً الدالة Dlookup . هذه فكرتي طبعاً الغير ملزمة وإنما ارتاح في تنفيذها ولم تسبب لي اي مشاكل منذ اعتمادها .

لوجود خطأ في نتائج البحث بعد التجربة ، قمت بالتعديل التالي على دالة البحث الرئيسية على سبيل المثال :- Sub SearchAll() Dim wsSearch As Worksheet Dim wsData As Worksheet Dim wsPensions As Worksheet Dim searchCol As Long Dim searchValue As String Dim resultRow As Long Dim visibleRange As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set wsSearch = ThisWorkbook.Sheets("Search") Set wsData = ThisWorkbook.Sheets("Data") Set wsPensions = ThisWorkbook.Sheets("معاشات") wsSearch.Range("A10:M1000").ClearContents resultRow = 10 For searchCol = 1 To 13 If Not IsEmpty(wsSearch.Cells(5, searchCol)) Then searchValue = Application.Clean(Trim(wsSearch.Cells(5, searchCol).Text)) With wsData .AutoFilterMode = False .Range("A4:M" & .Rows.Count).AutoFilter Field:=searchCol, Criteria1:=searchValue On Error Resume Next Set visibleRange = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible) If Not visibleRange Is Nothing Then visibleRange.Copy wsSearch.Cells(resultRow, 1).PasteSpecial xlPasteValues resultRow = resultRow + visibleRange.Rows.Count End If On Error GoTo 0 .AutoFilterMode = False End With With wsPensions .AutoFilterMode = False .Range("A4:M" & .Rows.Count).AutoFilter Field:=searchCol, Criteria1:=searchValue On Error Resume Next Set visibleRange = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible) If Not visibleRange Is Nothing Then visibleRange.Copy wsSearch.Cells(resultRow, 1).PasteSpecial xlPasteValues resultRow = resultRow + visibleRange.Rows.Count End If On Error GoTo 0 .AutoFilterMode = False End With Exit For End If Next searchCol Application.Calculation = xlCalculationAutomatic Application.CutCopyMode = False Application.ScreenUpdating = True End Sub توحيد البحث في شيت واحد_01.xlsb

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

بناءً على المطلوب الأخير لك ، ومشاركة مع أستاذنا @عبدالله بشير عبدالله ،، قمت بحذف الدوال السابقة للبحث ، واستبدلتها بفكرة واحدة بحيث ( لا حاجة فعلاً لتكرار البيانات في الأوراق جميعها ، وقد تم حذف البيانات في الورقة Search ، وستكون دالة البحث ودالة مسح وتنظيف نتائج البحث كالتالي :- Sub SearchAll() Dim wsSearch As Worksheet Dim wsData As Worksheet Dim wsPensions As Worksheet Dim searchCol As Long Dim searchValue As String Dim lastRowData As Long Dim lastRowPensions As Long Dim resultRow As Long Application.ScreenUpdating = False Application.EnableEvents = False Set wsSearch = ThisWorkbook.Sheets("SEARCH") Set wsData = ThisWorkbook.Sheets("DATA") Set wsPensions = ThisWorkbook.Sheets("معاشات") wsSearch.Range("A10:M1000").ClearContents resultRow = 10 For searchCol = 1 To 13 If Not IsEmpty(wsSearch.Cells(5, searchCol)) Then searchValue = wsSearch.Cells(5, searchCol).Value lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row If lastRowData > 4 Then With wsData.Range("A5:M" & lastRowData) .AutoFilter .AutoFilter Field:=searchCol, Criteria1:="=" & searchValue, _ Operator:=xlAnd On Error Resume Next .Offset(1).SpecialCells(xlCellTypeVisible).Copy wsSearch.Cells(resultRow, 1).PasteSpecial xlPasteValues On Error GoTo 0 .AutoFilter End With End If resultRow = wsSearch.Cells(wsSearch.Rows.Count, "A").End(xlUp).Row + 1 If resultRow < 10 Then resultRow = 10 lastRowPensions = wsPensions.Cells(wsPensions.Rows.Count, "A").End(xlUp).Row If lastRowPensions > 4 Then With wsPensions.Range("A5:M" & lastRowPensions) .AutoFilter .AutoFilter Field:=searchCol, Criteria1:="=" & searchValue, _ Operator:=xlAnd On Error Resume Next .Offset(1).SpecialCells(xlCellTypeVisible).Copy wsSearch.Cells(resultRow, 1).PasteSpecial xlPasteValues On Error GoTo 0 .AutoFilter End With End If Exit For End If Next searchCol Application.ScreenUpdating = True Application.EnableEvents = True Application.CutCopyMode = False End Sub Sub ClearSearch() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("SEARCH") ws.Range("A10:M1000").ClearContents ws.Range("A5:M5").ClearContents ws.Range("B5").Select End Sub توحيد البحث في شيت واحد_01.xlsb

أهلاً بك مهندسنا الغالي 💐 بالعكس ، قد تكون الكلمات القليلة تحمل في طياتها معاني وفوائد كبيرة 😇 . جاري حالياً العمل على إصدار النسخة الأولى معدلةً ، وسيتم طرحها قريباً ( غير مفتوحة المصدر ) - للتجارب فقط لحين الخلاص من أكثر المشاكل التي أواجهها في إنشاء مرونة بالنتيجة 😅 .

أولاً وعليكم السلام ورحمة الله وبركاته 🤗.. أخي الكريم هذا ليس أسلوب منطقي وصحيح ويتبع سياسة المنتدى في طرح موضوع جديد. العنوان في الموضوعين اللذين قمت بفتحهما لا يحققا شرط أن يكون العنوان دالاً على المطلوب. ثانياً قم بطرح الموضوع كاملاً هنا وليس في ملف PDF 😁 . ثالثاً وجوهره مهم هو أن تقوم بإرفاق ملف بسيط يعبر عن مطلبك شريطة أنه لا حاجة لإرسال مشروعك كاااااملاً . فقط ارسل العناصر والمكونات ذات الهدف والإختصاص . وليس لنا حاجة بأن تكون البيانات حساسة ، فيكفي بيانات عشوائية للتنفيذ. شكراً لك مقدماً 🤗😇 تم تصويب الأوضاع بواسطة مشرفنا @Moosak ، مشكوراً

تم انشاء استدعاء لدالة للتحديث التلقائي عند فتح الشيت Search في ThisWorkbook كالآتي :- Private Sub Workbook_SheetActivate(ByVal Sh As Object) If Sh.Name = "SEARCH" Then Call UpdateSearchSheet With ThisWorkbook.Sheets("SEARCH") .Range("B5").Select End With End If End Sub وطبعاً دالة التحديث التلقائي :- Sub UpdateSearchSheet() Dim wsSearch As Worksheet Dim wsData As Worksheet Dim wsPensions As Worksheet Dim lastRowData As Long Dim lastRowPensions As Long Dim lastRowSearch As Long Set wsSearch = ThisWorkbook.Sheets("SEARCH") Set wsData = ThisWorkbook.Sheets("DATA") Set wsPensions = ThisWorkbook.Sheets("معاشات") wsSearch.Range("A10:M1000").ClearContents lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row If lastRowData > 9 Then wsData.Range("A10:M" & lastRowData).Copy wsSearch.Range("A10").PasteSpecial xlPasteValues End If lastRowSearch = wsSearch.Cells(wsSearch.Rows.Count, "A").End(xlUp).Row If lastRowSearch < 10 Then lastRowSearch = 9 lastRowPensions = wsPensions.Cells(wsPensions.Rows.Count, "A").End(xlUp).Row If lastRowPensions > 9 Then wsPensions.Range("A10:M" & lastRowPensions).Copy wsSearch.Range("A" & lastRowSearch + 1).PasteSpecial xlPasteValues End If Application.CutCopyMode = False End Sub وبشكل اختياري ، زر تحديث يدوي :- Sub RefreshSearchData() Call UpdateSearchSheet With ThisWorkbook.Sheets("SEARCH") .Range("B5").Select End With MsgBox "تم تحديث البيانات بنجاح", vbInformation End Sub توحيد البحث في شيت واحد.xlsb

اممممم ، جميل يعني أحسن شيء و الأفضل هو ، أن يتم :- تصميم النماذج المراد استخدامها كـ Popup مسبقاً بهذه الخصائص . استخدام معلمة في OpenArgs لتحديد ما إذا كان النموذج سيفتح كـ Popup أو لا .. في حدث OnLoad للنموذج ، التحقق من OpenArgs وتعديل السلوك حسب الحاجة ( بدون تغيير الخصائص الأساسية ) . أعتقد هذا الحل يتجنب مشاكل الأمان ، وأيضاً يوفر مرونة معقولة ( نسبياً إلى حد ما 😅 ) دون الحاجة لتعديل التصميم أثناء التشغيل .

ما شاء الله تبارك الله !!! ايه التحفة الجميلة دي أداة رائعة بالفعل ومهنية في تنظيم التنقل بين النماذج ، وأعجبتني عدة مميزات فيها :- التصميم المتكامل : التعداد FormOpenMode شامل ويغطي جميع حالات الفتح تقريباً ، مما يجعل الأداء مرناً وقابلاً للتوسعة . وطبعاً التحكم الدقيق من خلال دعم WhereCondition و OpenArgs يضيف طبقة احترافية للتواصل بين النماذج . وهنا تحفة فنية عجبتني كمان وهي منع التكرار من خلال lastCall فكرة ذكية لتجنب إهدار الموارد . بس سؤال خطر على بالي ، وأكيد لم يخف عنك يا تحفتنا هل يمكن إضافة خاصية فتح نموذج كـ "Popup" (نافذة منبثقة) لوضع acWindowNormal مع إمكانية التمرير فوق النماذج الأخرى . جزاك الله خيراً على هذا المجهود ، وجعلها في ميزان حسناتك

حسناً ، سأرى ما يمكنني فعله عند عودتي للمنزل ان شاء الله مساءً .. وقد نبحث عن حل آخر لحل مشكلة تتالي التحديث على البيانات

بارك الله بكم معلمنا الفاضل وأستاذي الجليل ,, قيّمة جداً وثمينة مراجعك التي تشير إليها في مشاركاتك ، وهي ليست بقيمة و نُبل أخلاقكم وعلمكم وعليكم السلام ورحمة الله وبركاته ,, أشكرك أخي على مشاعرك وكلامك اللطيف ،

وعليكم السلام ورحمة الله وبركاته ,, باعتقادي وبرأيي ، يظهر هذا الخطأ لأنه لديك سجلات في جدول الربط TAB_taking_X تحتوي على قيم في حقل BookID لا تتوافق مع أي قيم في حقول ID في الجداول bookX أو bookX2 . قم بحذف بيانات الجداول الثلاثة ، وأعد تطبيق العلاقات ستجد أنها تمت بشكل صحيح .. السبب طبعاً أنه يجب أولا بناء العلاقات قبل ادخال البيانات ليتم الربط فيما بين الجداول حسب شروط العلاقات . أما اذا أردت المحافظة على بياناتك ، فأعتقد عليك إعادة ربط القيم الرقمية بشكل صحيح بشكل يدوي ، ثم لاحظ انك تعتمد على الترقيم التلقائي كرقم فريد للسجل ( وهنا اعتقد انك قد تواجه مشاكل في الترقيم لاحقاً مع تكرار الحذف والإضافة ) . لذا حاول استخدام مثلاً DMAX أو أي ترقيم آخر يكون في حقل مستقل من نوع رقمي بديلاُ عن الترقيم التلقائي في ID في الجدولين bookX أو bookX2 .