Foksh

نعم فهمتك على ما أعتقد ، انت تريد زر الطباعة أن يعمل على أي تقرير تم فتحه ( في الوقت الحالي ) ، صحيح ؟؟ سنحاول الإستفادة من المتغير العام :- 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 .

وعليكم السلام ورحمة الله وبركاته ,, أشكرك على هذه الثقة أخي الفاضل @algammal ، وأتمنى ان نكون عند حسن الظن بها .. وطبعاً البركة في خبرائكم ومعلمينا الأفاضل هنا ، فأنا ما زلت اكتسب المعلومة في هذا الصرح الكبير . بحد علمي وفهمي البسيط في اكسل ، قمت بدمج بيانات الشيتين (search DATA) و (search معاشات) في الشيت Search . ثم جعلت الفلترة بشكلين ، إما عن موظف محدد باسمه مثلاً أو رقمه القومي كبيانات فريدة ( افتراضاً مني ) ، أو الفلترة الشاملة كما في الصورة :- واستخدمت الماكرو الأول للـ بحث عن سجل محدد :- Sub SearchOne() Dim ws As Worksheet Dim findRange As Range Dim searchCol As Long Dim searchValue As String Dim foundCell As Range Dim lastRow As Long Set ws = ThisWorkbook.Sheets("SEARCH") For searchCol = 1 To 13 If Not IsEmpty(ws.Cells(5, searchCol)) Then searchValue = ws.Cells(5, searchCol).Value lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set findRange = ws.Range(ws.Cells(10, searchCol), ws.Cells(lastRow, searchCol)) Set foundCell = findRange.Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole) If Not foundCell Is Nothing Then ws.Range(foundCell.EntireRow.Address).Copy ws.Range("A5").PasteSpecial xlPasteValues Exit For End If End If Next searchCol Application.CutCopyMode = False End Sub وفي زر الفلترة الشاملة :- Sub SearchAlls() Dim ws As Worksheet Dim searchCol As Long Dim searchValue As String Dim lastRow As Long Set ws = ThisWorkbook.Sheets("SEARCH") If ws.AutoFilterMode Then ws.AutoFilterMode = False For searchCol = 1 To 13 If Not IsEmpty(ws.Cells(5, searchCol)) Then searchValue = ws.Cells(5, searchCol).Value lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ws.Range("A9:M" & lastRow).AutoFilter ws.Range("A9:M" & lastRow).AutoFilter Field:=searchCol, Criteria1:=searchValue Exit For End If Next searchCol End Sub وفي زر مسح الفلترة :- Sub ClearSearch() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("SEARCH") If ws.AutoFilterMode Then ws.AutoFilterMode = False ws.Range("A5:M5").ClearContents End Sub هذا بحد فهمي للمطلوب ، وأرجو ان لا أكود قد صوبت إجابتي بشكل بعيد كلياً عن المطلوب ,🙃, الملف بعد التعديل :- توحيد البحث في شيت واحد.xlsb جرب النتائج ، وأخبرني بها .

شكراً لك على الإضافة الجميلة ، وإن شاء الله سأستفيد من هذا الرد في تعديلات الأداة لاحقاً .. طبعاً ومعلومة مهمة بالنسبة لي ، أن الأداة ستحمل اسم فريق المنتدى / قسم آكسيس كاملاً لدعمهم الوفير في المعلومات ..

من تواضع لله رفعه ، وانت من الأساتذة الذين لهم بصماتهم وأسلوبهم

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

أهلا بأخي @ناقل ، يسعدني مرورك وتعقيبك على الموضوع ، رغم انك تسرعت في الحكم علي 😁😁 بالعكس ، أساتذتي الخبراء من المستهدفين بالمشاركة في هذا النقاش ( طبعاً مع احترامي الكامل لحرية ابداء الرأي ) ، انظر .. وتعقيباً على ما أسلفت تالياً :- ففي الحسبان ان شاء الله ، ولكن الصورة والفكرة السابقة من الإصدار الأول للتجارب الأولى لجمع التعليقات والمعلومات التي نستفيد منها .. معلمي الفاضل @ابوخليل ، أُسعد بمشاركتكم ، واتمنى أن أصل في النهاية إلى أداة تحقق الجزء الأكبر من فكرتها وهدفها .. بانتظار توجيهاتكم وإفاداتكم وتصويبكم لي لطرق تسهم في إنجاح المشروع .. معلمي الفاضل @jjafferr ، يسعدني توجيهكم لي بهذه الروابط ، وانا فعلاً قد قرأتها بشكل غير مفصل ، ولكن قراءتي لها كانت محاولة لرسم خطواتي التي سأبدأ بها ، وطبعاً لا بد من تغيير اتجاهي في الوقت الحالي واتجاه بوصلتي ، طبعاً بهدف البدء بخطوات صحيحة تالياً .. أما فيما يخص الكود الذي استخدمته كتجربه ، فيسعدني توجيهك من موقع مايكروسوفت ، دلالة على أن المصادر التي يجب علي اتباع نهجها يجب أن تكون موثوقة لاحقاً .. أخي الأستاذ @kkhalifa1960 ، يسعدني تعليقكم ومروركم ، وإثراءكم وملاحظتكم كثيراً .. ونأمل أن نتعرف على أفكاركم لاحقاً باحثين عن سبيل واسع الأفق لتحقيق المطلوب . أما فيما يخص هذا الجزء .. فطبعاً صديقي وحبيبي @ابو جودي ، من الذين أشاركهم أفكاري وأستنير بتعليقاتهم ، حاله حال أساتذتي ومعلميني الأفاضل ( دون استثناء طبعاً ) . لكن وضعه الحالي الصحي قد يجعل تعليقاته متاحة فيما بيننا خارج المنتدى . ( يعاني من كسر في يده اليمنى حالياً شافاه الله وعافاه شفاء عاجل غير آجل ) . وباسمي وباسم المنتدى نيابةً نتمنى له الشفاء القريب بإذن الله . أشكر لكم جميعاً مروركم وقريباً سنبدأ بطرح الفكرة من بدايتها ( النسخة الأولى من الأداة ) ، ومع توجيهاتكم معلميني وأساتذتي وأخواني ، سنبدأ بتصحيح المسارات الخاطئة عند وجودها وإنجاح الفكرة .

السلام عليكم ورحمة الله وبركاته ،، في طور تحسين الأداة الجديدة ( لم يعلن عنها بعد ) ، للتعامل مع الأكواد التي تعمل على 32 ولا تعمل على 64 ، ما زال العمل جاري على تحسين أداء الأداة ، بحيث من خلال النقاش المفتوح نأتي للوصول الى أفضل أداء ونتيجة . مرفق صورة توضيحية للوضع الحالي للأداة ، مع طرح مثال لكود قبل وبعد التحويل الناتج من الأداة . الكود الذي تمت التجربة عليه كمثال ( لا الحصر ) :- Option Compare Database Option Explicit Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As _ Any) As Long Public Const WM_SETREDRAW = &HB Public Sub FillChildren(twTree As MSComctllib.TreeView, rst As dao.Recordset, _ ByVal nChild As MSComctllib.nodX, _ strParentField As String, strIDField As String, _ strTextField As String, Optional strTextField2 As Variant, Optional strTextField3 As Variant, Optional strTextField4 As Variant, Optional strTextField5 As Variant, _ Optional strKeyPrefix As String, _ Optional varImage As Variant, _ Optional varImageRst As Variant, _ Optional fBold As Boolean) On Local Error GoTo FillChildren_Err Dim strCriteria As String, IMAGE As Variant, strPrefix As String, strText As String, newnodx As MSComctllib.nodX If strKeyPrefix = "" Then strPrefix = "a" Else strPrefix = strKeyPrefix End If If Mid(nChild.key, 2) = "0" Then strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2) & " or is null") Else strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2)) End If rst.FindFirst strCriteria Do Until rst.NoMatch strText = Nz(rst(strTextField), " ") If Not IsMissing(strTextField2) Then strText = strText & (" " + rst(strTextField2)) If Not IsMissing(strTextField3) Then strText = strText & (" " + rst(strTextField3)) If Not IsMissing(strTextField4) Then strText = strText & (" " + rst(strTextField4)) If Not IsMissing(strTextField5) Then strText = strText & (" " + rst(strTextField5)) If Not IsMissing(varImageRst) Then IMAGE = rst(varImageRst) End If If (Not IsMissing(varImage)) And (Len(Nz(IMAGE)) = 0) Then IMAGE = varImage End If IMAGE = Nz(IMAGE, "Default") Set newnodx = twTree.Nodes.Add(nChild, tvwChild, strPrefix & rst(strIDField), strText, IMAGE) rst.FindNext strCriteria Loop FillChildren_End: On Error Resume Next Exit Sub FillChildren_Err: Select Case Err.Number Case 35601, 35603 'Image not found!!! IMAGE = "FlagDefault" Resume Case 35602 'key not unique!!! Set newnodx = twTree.Nodes(strPrefix & rst(strIDField)) Resume Next Case Else MsgBox "Error in FillChildren!!! " & Err.Number & Err.Description Stop Resume End Select End Sub النتيجة من الأداة بعد التحسينات والتعديلات :- 'Code converted to 64-bit compatibility By Foksh ( Officena.Net ) 'Generated on: 2025-05-23 15:22:26 'Tool version: Ver : 1.0 Option Compare Database Option Explicit #If VBA7 Then Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As Long, lParam As Any) As Long #Else Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long #End If Public Const WM_SETREDRAW = &HB Public Sub FillChildren(twTree As MSComctllib.TreeView, rst As dao.Recordset, _ ByVal nChild As MSComctllib.nodX, _ strParentField As String, strIDField As String, _ strTextField As String, Optional strTextField2 As Variant, Optional strTextField3 As Variant, Optional strTextField4 As Variant, Optional strTextField5 As Variant, _ Optional strKeyPrefix As String, _ Optional varImage As Variant, _ Optional varImageRst As Variant, _ Optional fBold As Boolean) On Local Error GoTo FillChildren_Err Dim strCriteria As String, IMAGE As Variant, strPrefix As String, strText As String, newnodx As MSComctllib.nodX If strKeyPrefix = "" Then strPrefix = "a" Else strPrefix = strKeyPrefix End If If Mid(nChild.key, 2) = "0" Then strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2) & " or is null") Else strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2)) End If rst.FindFirst strCriteria Do Until rst.NoMatch strText = Nz(rst(strTextField), " ") If Not IsMissing(strTextField2) Then strText = strText & (" " + rst(strTextField2)) If Not IsMissing(strTextField3) Then strText = strText & (" " + rst(strTextField3)) If Not IsMissing(strTextField4) Then strText = strText & (" " + rst(strTextField4)) If Not IsMissing(strTextField5) Then strText = strText & (" " + rst(strTextField5)) If Not IsMissing(varImageRst) Then IMAGE = rst(varImageRst) End If If (Not IsMissing(varImage)) And (Len(Nz(IMAGE)) = 0) Then IMAGE = varImage End If IMAGE = Nz(IMAGE, "Default") Set newnodx = twTree.Nodes.Add(nChild, tvwChild, strPrefix & rst(strIDField), strText, IMAGE) rst.FindNext strCriteria Loop FillChildren_End: On Error Resume Next Exit Sub FillChildren_Err: Select Case Err.Number Case 35601, 35603 'Image not found!!! IMAGE = "FlagDefault" Resume Case 35602 'key not unique!!! Set newnodx = twTree.Nodes(strPrefix & rst(strIDField)) Resume Next Case Else MsgBox "Error in FillChildren!!! " & Err.Number & Err.Description Stop Resume End Select End Sub باب النقاش مفتوح لأي تعليقات وتوضيحات وتحديثات للجميع .. الأداة حصرية وليس لها أي أساس في أي موقع أجنبي أو عربي ( فقط في أوفيسنا ) *ملاحظة :- الدعوة للنقاش لا تقتصر على من لديه خبرة في آكسيس فقط . أيضاً أخوتنا الأساتذة برتبة ( خبير ) الذين أشعر أنهم غير معنيين بالمشاركة بمواضيع أخوتهم الأساتذة في هذا المنتدى هم معنيين خصوصاً بالمشاركة وإبداء الرأي ، وأرجو ان لا تكون هذه العبارة في غير محلها 😎 . نحن نتكاتف هنا لنتشارك معرفتنا وعلمنا الذي علمنا إياه الله - ولا علم إلا علمه . لذا متأملاً منهم خصوصاً مشاركتنا أفكارهم . 💥 الإداة بواجهتين ( عربي - انجليزي ) والرسائل والردود حسب كل لغة Code Converter x64.zip85.95 kB · 8 downloads Code Converter x32.zip80.96 kB · 5 downloads طبعاً ، أتمنى ممن يرغب بتجربة الأداة بأول إصدار لها ، أن يزودني بالنتيجة التي قام بها على الكود ، بحيث :- ينشر في رده الكود الأصل ( الذي قام بتجربته ) ، والكود الناتج ( بعد تحويله من الأداة ) لتعم الفائدة ولمعرفة الأخطاء التي قد تحدث ( ولا شك أن الأداة تحتوي أخطاء كثيرة ، ولكن لإجراءاتكم بالإفادة ) . إن كان يملك الكود الصحيح والمنطقي ( الذي يعمل على النواتين ) ، فشاكراً له تزويدنا به للمقارنة . Code Converter x32.zip80.96 kB · 5 downloads Code Converter x64.zip85.95 kB · 8 downloads