نجوم المشاركات

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 اليوم سأقدم لكم فكرة لإنشاء ساعة رقمية مشابهة لألواح الإعلانات المضيئة ، ولكن بطريقة و نكهة مختلفتين كالعادة ▫▪◽◾◻◼ . صورة للنتيجة .. المرفق مفتوح المصدر دون إطالة BackLight2.accdb

عشان تعرف بس معزتك قد ايه

هل هذا ما تقصده ؟؟ جرب سجل الدخول بأي اسم مستشفى ، ستلاحظ انشاء مجلد خاص باسم المستشفى بجانب قاعدة .. inv4.accdb

Public Sub SplitNumbersIntoTextBoxes(inputText As String, ParamArray textBoxes() As Variant) Dim i As Integer Dim numLength As Integer numLength = Len(inputText) For i = 1 To numLength If i <= UBound(textBoxes) + 1 Then If TypeName(textBoxes(i - 1)) = "TextBox" Or TypeName(textBoxes(i - 1)) = "Control" Then textBoxes(i - 1).Value = Mid(inputText, i, 1) End If End If Next i Exit Sub End Sub ضع الكود السابق في وحدة نمطية قم باستدعائه هكذا: Call SplitNumbersIntoTextBoxes([هنا حقل الرقم الوطني], Me.txtBox1, Me.txtBox2) قم بتغيير الاسماء في الاستدعاء حسب مربعات النص التي تريد تقسيم الرقم فيها يمكنك اضافة العدد الذي تريد من المربعات حسب حاجتك

سبق وأن طبقت حالة مشابهة فى تقرير لإظهار استمارة 1_سري للمدرسين بهذه الدالة =Mid([National_Nr];14;1) =Mid([National_Nr];13;1) . . حيث National_Nr هو حقل الرقم القومى الأرقام 14 ، 13 ، ... ، 1 هى ترتيب كل رقم داخل هذا الحقل من اليمين لليسار بينما رقم 1 المكرر فى كل دالة معناه اختيار عدد واحد فقط من 14 رقم ربما توجد طريقة أسهل من الزملاء .. لكن هذا الذى حقق الغرض عندى .

رووووووووعة ما شاء الله تبارك الرحمن 😊👌🌹 الفكرة بحد ذاتها جميلة وعبقرية .. 🙂 ومشاركة مني عملت منها نسخة مصغرة عشان يسهل وضعها في النماذج .. ساعة رقمية للمهندس فادي.accdb

دى فكرتى فى وحدة نمطيه عامة نضع الكود التالى Public Sub SplitNationalID(formOrReport As Object, nationalID As String) Dim i As Integer Dim ctrl As Control ' التأكد من أن الرقم القومي يحتوي على 14 رقمًا If Len(nationalID) <> 14 Then MsgBox "الرقم القومي يجب أن يتكون من 14 رقمًا!", vbExclamation Exit Sub End If ' فصل الرقم القومي إلى أرقام فردية وتعيينها إلى مربعات النص For Each ctrl In formOrReport.Controls If TypeName(ctrl) = "TextBox" And Left(ctrl.Name, 3) = "txt" Then i = Val(Mid(ctrl.Name, 4)) ' استخراج الرقم من اسم مربع النص (مثل txt1, txt2, إلخ) If i >= 1 And i <= 14 Then ctrl.Value = Mid(nationalID, i, 1) End If End If Next ctrl End Sub على ان يكون فى النموذج عدد 15 مربع النص مربع النص الاول يكون باسم : txtNationalID والباقى تكون اسمائهم txt1 الى txt14 وزر امر عند الضغط عليه يتم استدعاء الدالة بالشكل التالى SplitNationalID Me, Me.txtNationalID.Value ونفس الموضوع للتقرير على ان يتم الاستدعاء عند الفتح وانا اكتب انت تضع المرفق لا وبتفكر زى افكار بس انا فكرتى اكثر مرونه منك 😛😄

هذه محاولتي البسيطة Test ID.accdb

ايه ده مش ممكن نفكر بمرونه شويه يا ناس ؟ افضل انا اكتب اسماء ال 14 مربع نص فاضى انا بقه صح طبعا امزح مع استاذى و معلمى الاستاذ القدير @AlwaZeeR

السلام عليكم أخي محمد جرب احد حلول على طريقة تحقق من مسار الصور DataH.zip

لم انتبه لردك استاذ @Eng.Qassim الا بعد اضافة ردي 🤦🏻‍♂️

عذرا والله كان بالخطأ

أولاً أخي الكريم ،، اختيار أفضل إجابة تختارها للحل ، وليس لصاحب الموضوع

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub SaveAsPDF11() Dim WS As Worksheet, CrWS As Worksheet Set WS = ActiveSheet: Set CrWS = Sheets("مشروع 1") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False WS.Range("B2:I47").FormatConditions.Delete WS.Range("A1:Z999").AutoFilter Field:=1, Criteria1:="<>" savePath = "d:\" & WS.Range("AA1").Value & " " & Format(Now, "yyyy-mm-dd,hh.mm") & ".pdf" WS.Range("A1:Z999").ExportAsFixedFormat Type:=xlTypePDF, Filename:=savePath CrWS.Range("B2:I47").Copy WS.Range("B2").PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub

السلام عليكم بعد إذن الاستاذ/ خليفة أخي اليك احد حلول testH.accdb

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub CopyData() Dim ColArr() As Variant, Irow&, lr& Dim OnRng As Range, f As Worksheet Dim WS As Worksheet: Set WS = Sheets("ملخص") Application.ScreenUpdating = False WS.Range("A2:Q" & WS.Rows.Count).ClearContents For Each f In ThisWorkbook.Sheets If f.Name <> WS.Name Then Irow = f.Cells(f.Rows.Count, "D").End(xlUp).Row If Irow > 2 Then If WS.Cells(2, 1).Value = "" Then WS.Range("A2:Q2").Value = f.Range("A2:Q2").Value End If Set OnRng = f.Range("A3:Q" & Irow) ColArr = OnRng.Value lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 WS.Cells(lr, "A").Resize(UBound(ColArr, 1), UBound(ColArr, 2)).Value = ColArr End If End If Next f Application.ScreenUpdating = True End Sub Book1 v2.xlsb

للتوضيح ، يبدو أنني لم أفسر بشكل أوضح أخي الكريم .. بعد تسجيلك للدخول باسم الموظف سيتم انشاء المجلد عندما تختار اضافة مرفقات PDF ..

تمت التجربة .. ظهر المجلد والملف داخله

رائع وجميل .. وفكرة متعوب عليها سؤال : عن الدائرة في مربع التسمية هل تم تصميمه خارج اكسس ؟

دائماً ترفع معنوياتي بمداخلاتك وما شاء الله عليك مهندسنا الغالي ,, سلمت على هديتك ومشاركتك الجميلة

انظر الفرق والتغيير بين الكودين الكود الأول يزيل كلمة New folder المثبتة ضمن الكود وعدد الأحرف = 12 الثاني : لا يوجد كلمة محددة .. فقط يكتفى بعدد الحروف التي = 6

واكثر مما كنا نريد فجزاك الله خير الجزاء وبيض الله وجهك وزادك الله من علمه وعاجز عن الشكر لك اخي ومعلمي الغالي واشكر استاذي ابو ابوخليل والاستاذ الغالي kkhalifa1960 على ماقدموه من مشاركة وافكار جميله واسمحو لي سوف اقوم الايام المقبله بإضافة فواتير باعداد كبيره واختبار الملفات بشكل دقيق ولو حدث معاي اي ملاحظة سوف اقوم بإبلاغكم على هذا الموضوع تحياتي للجميع

وعليكم السلام ورحمة الله وبركاته الكود Sub تجميع_البيانات() Dim wsSummary As Worksheet Dim ws As Worksheet Dim lastRow As Long Dim summaryLastRow As Long Dim dataRange As Range On Error Resume Next Set wsSummary = ThisWorkbook.Sheets("ملخص") On Error GoTo 0 If wsSummary Is Nothing Then Set wsSummary = ThisWorkbook.Sheets.Add wsSummary.Name = "ملخص" End If wsSummary.Rows("3:" & wsSummary.Rows.Count).ClearContents summaryLastRow = 3 For Each ws In ThisWorkbook.Sheets If ws.Name <> wsSummary.Name Then lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If lastRow >= 3 Then Set dataRange = ws.Range("A3:Q" & lastRow) wsSummary.Cells(summaryLastRow, "A").Resize(dataRange.Rows.Count, dataRange.Columns.Count).Value = dataRange.Value summaryLastRow = summaryLastRow + dataRange.Rows.Count End If End If Next ws MsgBox "تم تجميع البيانات !", vbInformation End Sub الملف Book1.xlsb

يعطيك العافية استاذ عبدالله واعتذر على الاطالة صحيح يحفظ الان بدون التنسيق الشرطي ولكن اصبح يخفي التلوين العادي للصفوف والخلاياء التي ليست تنسيق الشرطي والمشكلة الثانية عندما انسخ ورقة العمل المشروع 1 الى مشروع 2 ومشروع 3 ومشروع 4 ومشروع 5 ومشروع 6 ومشروع 7 وووو يعمل على المشروع الاول فقط هل يمكن الغاء تحديد الشيت بحيث يعمل على الي شيت يتم نسخ الشيت ((المشروع)) ولك جزيل الشكر

(تحديث) مرفق مقترح للمقارنة هل يفى بالمطلوب الاصناف الراكدة لكل مخزن(5).xlsm

بارك الله فيك اخي الكريم جزاك الله خيرا

افتح التقرير من الفورم نتحصل طلبك .!!!!!!!!

جرب التعديل التالي توجد ورقة مخفية يتم نسخ البياتان اليها ومنها يتم تحويل الى PDF ترحيل بدون تنسيق شرطي.xlsb

استاذ @فؤاد الدلوي . 1- اذهب هنــــــا وسدد ب تمت الاجابة . 2- تفضل طلبك بالمرفق التالي . ووافني بالرد . 3- اذا كان هذا طلبك ايضاً سدد بـ تمت الاجابة . وشكراً . test (112).rar

السلام عليكم قاعدة التطبيق تم عملها على أكسس 2003 وهى تعمل أيضاً على أى أكسس حتى 2024 أكواد القاعدة تحتوى على الكثير والكثير من الأفكار والحيل الرائعة لمحترفى أعضاء المنتدى منهم أبو هادى والأخت زهرة وسيد عبدالعال وابو خليل وغيرهم من الأحباء القدامى والجدد لا أدعى أن البرنامج قد حقق الكثير من أهدافه ، لكنه أرضى كل مدرسة هنا قامت باستخدامه الرقم السري للدخول " 1 " ويمكن تغييره فى الإعدادات وإليكم بعض الصور لشاشاته تحياتى لجميع أعضاء أوفيسنا ، والشكر الكبير لهذا المنتدى العريق بيانات المدرسين.rar

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

استاذ @تامر خليفه إذا حبيت تستبدل الأسماء تفضل . انتبه أنا وضعت اسمك ولكن يمكنك التغيير .................... وواقني بالرد . تفضل المرفق . DDTempTest 002.rar

مشاركة مع الاساتذة تفضل استاذ @تامر خليفه هذا المرفق واليك الشرح التالي :- ووافني بالرد . DDTempTest 001.rar

بالعكس الحقل يظهر ، لكن المشكلة واعتقد انها بسبب فرق اصدار الأوفيس ، أن قيم الحقل = نعم / لا على عكس الحقل الذي قمت انا بإضافته لتمييز السجلات التي تم استرجاعها . على العموم ، تفضل هذا المرفق يا صديقي بعد التعديلات التي طلبتها .. في نموذج الاسترجاع تم حذف الأجزاء المتعلقة بالحذف للفواتير التي مضى عليها شهر ، واعتماد فكرة مربع النص والمسار ، لكنني طبعاً لم أقم بضم مربع النص للجدول الجديد وتركت لك حرية الأمر .. كود الترحيل ( التصدير ) :- Private Sub COM1_Click() On Error GoTo ErrorHandler Dim db1 As DAO.Database Dim db2 As DAO.Database Dim rst1 As DAO.Recordset Dim rstCheck As DAO.Recordset Dim strSQL As String Dim strCheck As String Dim intCount As Integer Dim fd As Office.FileDialog If IsNull(Me.Zak_Path.Value) Or Me.Zak_Path.Value = "" Then Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "اختر ملف قاعدة البيانات" .Filters.Clear .Filters.Add "قواعد بيانات Access", "*.accdb" .AllowMultiSelect = False If .Show = -1 Then Me.Zak_Path.Value = .SelectedItems(1) Else MsgBox "لم يتم اختيار ملف", vbExclamation + vbMsgBoxRight, "" Exit Sub End If End With End If strPath2 = Me.Zak_Path.Value Set db1 = CurrentDb Set db2 = DBEngine.OpenDatabase(strPath2) strCheck = "SELECT COUNT(*) AS NewCount " & _ "FROM TBInvoiceMain " & _ "WHERE ZatcaXMLSent = -1 AND ID NOT IN " & _ "(SELECT ID FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2)" Set rstCheck = db1.OpenRecordset(strCheck) If Not rstCheck.EOF Then If rstCheck!NewCount = 0 Then MsgBox "لا توجد فواتير جديدة للترحيل", vbInformation + vbMsgBoxRight, "" GoTo CleanUp End If If MsgBox("سيتم نقل " & rstCheck!NewCount & " فاتورة . هل تريد المتابعة؟", _ vbQuestion + vbMsgBoxRight + vbYesNo, "") = vbNo Then GoTo CleanUp End If End If strSQL = "SELECT DISTINCT TBInvoiceMain.* " & _ "FROM TBInvoiceMain " & _ "WHERE ZatcaXMLSent = -1 AND ID NOT IN " & _ "(SELECT ID FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2)" Set rst1 = db1.OpenRecordset(strSQL) intCount = 0 If Not rst1.EOF Then Do While Not rst1.EOF On Error Resume Next strSQL = "INSERT INTO [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "SELECT ID, ID2, InvoiceNumber, FormNumber, InvoiceType, UUID, " & _ "InvoiceSerial, InvoiceDate, InvoiceTime, InvoiceTypeCodeID, " & _ "InvoiceTypeCodeName, InvoiceHash, DateSupply, EndDateSupply, " & _ "PaymentMethod, InstructionNote, TotalDiscount, DiscountReason, " & _ "TaxCode, TaxCodeName, TaxPercentage, InvoiceQR, InvoiceXmlName, " & _ "InvoiceXmlFullPath, EncodedInvoice, XMLCreated, SendingStatus, " & _ "ZatcaStatusCode, ZatcaXMLSent, ZatcaWarningMessage, ZatcaErrorMessage, " & _ "ClearedInvoice, BuyerStreetName, BuyerAdditionalStreetName, " & _ "BuyerBuildingNumber, BuyerPlotIdEntification, BuyerCityName, " & _ "BuyerPostalCode, BuyerCountrySubEntity, BuyerCitySubDivisionName, " & _ "BuyerCompanyName, BuyerTaxNumber, clearedXmlFullPath, BuyerCommercialRegistrationNo " & _ "FROM TBInvoiceMain WHERE ID = " & rst1!ID db1.Execute strSQL If Err.Number = 0 Then strSQL = "INSERT INTO [;DATABASE=" & strPath2 & "].TBInvoiceSub2 " & _ "SELECT ID, InvoiceNumber, ItemName, Quantity, ItemPriceBeforeTax, " & _ "TaxPercentage, TaxCode, Discount " & _ "FROM TBInvoiceSub WHERE ID = " & rst1!ID db1.Execute strSQL If Err.Number = 0 Then intCount = intCount + 1 End If End If On Error GoTo ErrorHandler rst1.MoveNext Loop strSQL = "DELETE TBInvoiceSub.* " & _ "FROM TBInvoiceSub INNER JOIN TBInvoiceMain ON TBInvoiceMain.ID = TBInvoiceSub.ID " & _ "WHERE DateDiff('d', TBInvoiceMain.InvoiceDate, Date()) > 30" db1.Execute strSQL strSQL = "DELETE TBInvoiceMain.* " & _ "FROM TBInvoiceMain " & _ "WHERE DateDiff('d', InvoiceDate, Date()) > 30" db1.Execute strSQL If intCount > 0 Then MsgBox "تم ترحيل " & intCount & " فاتورة بنجاح" & vbCrLf & _ "وتم حذف الفواتير الأقدم من 30 يوم", vbInformation + vbMsgBoxRight, "" Else MsgBox "لم يتم ترحيل أي فواتير", vbInformation + vbMsgBoxRight, "" End If End If CleanUp: If Not rst1 Is Nothing Then rst1.Close If Not rstCheck Is Nothing Then rstCheck.Close Set rst1 = Nothing Set rstCheck = Nothing If Not db2 Is Nothing Then db2.Close Set db2 = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء عملية الترحيل", vbCritical + vbMsgBoxRight, "" Resume CleanUp End Sub كود الإسترجاع ( الإستيراد ) :- Private Sub COM1_Click() On Error GoTo ErrorHandler If IsNull(Me.Text1) Or Trim(Me.Text1) = "" Then MsgBox "الرجاء إدخال رقم الفاتورة المطلوب استرجاعها", vbExclamation + vbMsgBoxRight, "" Me.Text1.SetFocus Exit Sub End If If Not IsNumeric(Me.Text1) Then MsgBox "الرجاء إدخال رقم فاتورة صحيح", vbExclamation + vbMsgBoxRight, "" Me.Text1.SetFocus Exit Sub End If Dim db1 As DAO.Database Dim db2 As DAO.Database Dim rst1 As DAO.Recordset Dim strSQL As String Dim strPath2 As String Dim lngInvoiceNumber As Long Dim fd As Office.FileDialog Dim intDeletedCount As Integer If IsNull(Me.Zak_Path.Value) Or Me.Zak_Path.Value = "" Then Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "اختر ملف قاعدة البيانات" .Filters.Clear .Filters.Add "قواعد بيانات Access", "*.accdb" .AllowMultiSelect = False If .Show = -1 Then Me.Zak_Path.Value = .SelectedItems(1) Else MsgBox "لم يتم اختيار ملف", vbExclamation + vbMsgBoxRight, "" Exit Sub End If End With End If strPath2 = Me.Zak_Path.Value lngInvoiceNumber = CLng(Trim(Me.Text1)) Set db1 = CurrentDb Set db2 = DBEngine.OpenDatabase(strPath2) strSQL = "SELECT COUNT(*) AS InvCount " & _ "FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "WHERE ID = " & lngInvoiceNumber Set rst1 = db1.OpenRecordset(strSQL) If rst1!InvCount = 0 Then MsgBox "الفاتورة رقم " & lngInvoiceNumber & " غير موجودة في قاعدة البيانات الثانية", vbExclamation + vbMsgBoxRight, "" GoTo CleanUp End If strSQL = "SELECT COUNT(*) AS InvCount FROM TBInvoiceMain " & _ "WHERE ID = " & lngInvoiceNumber Set rst1 = db1.OpenRecordset(strSQL) If rst1!InvCount > 0 Then If MsgBox("الفاتورة موجودة بالفعل في القاعدة الحالية . هل تريد استرجاعها مرة أخرى؟", _ vbQuestion + vbYesNo + vbMsgBoxRight, "") = vbNo Then GoTo CleanUp End If End If strSQL = "INSERT INTO TBInvoiceMain " & _ "SELECT * FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "WHERE ID = " & lngInvoiceNumber db1.Execute strSQL strSQL = "INSERT INTO TBInvoiceSub " & _ "SELECT * FROM [;DATABASE=" & strPath2 & "].TBInvoiceSub2 " & _ "WHERE ID = " & lngInvoiceNumber db1.Execute strSQL strSQL = "UPDATE TBInvoiceMain SET Tran = -1 WHERE ID = " & lngInvoiceNumber db1.Execute strSQL MsgBox "تم استرجاع الفاتورة رقم " & lngInvoiceNumber & " بنجاح", vbInformation + vbMsgBoxRight, "" Me.Text1 = "" Me.Text1.SetFocus CleanUp: If Not rst1 Is Nothing Then rst1.Close Set rst1 = Nothing If Not db2 Is Nothing Then db2.Close Set db2 = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء عملية الاسترجاع", vbCritical + vbMsgBoxRight, "" Resume CleanUp End Sub إلى الآن هل الأمور تسير كما نريد ؟؟ المرفقات.zip

تم التعديل بإذن الله .. تم التعديل بحيث عند استرجاع فاتورة ( جرب على الفاتورة رقم 4 حيث تم التعديل للتاريخ = 2024-11-16 للتجربة) ، سيتم سؤال المستخدم انه هذه الفاتورة مضى عليها أكثر من 30 يوم ، هل تريد الحذف ( الأمر متروك للمستخدم بالحذف أو لا ..) في اي جزء لاحظت انه لا يتم الترحيل بشكل صحيح ...؟ فبناءً على الملف المرفق تمت التجربة على السجلات بشكل منفصل والتدقيق قبل وبعد الترحيل أو الإستيراد . اذا تمكنت من ارفاق صورة أو توضيح لتلافي المشكلة ، وأكيد في الأمور المالية والحسابية الخطأ يكون قاتلاً Zakat.zip

وعليكم السلام ورحمة الله وبركاته أستاذ @سلمان الشهراني ، لي مداخلة بسيطة :- في مثالك لاحظت ان رقم الفاتورة مكرر في سجلات القاعدة الأولى ، هل هذا منطقي أم هو مجرد مثال ؟؟ في حال كان هو فعلاً كذلك ، فعلى أي أساس نريد استرجاع فاتورة محددة قد يكون لها سجلات مكررة بنفس رقم الفاتورة ؟؟؟؟؟ على العموم إليك اقتراحي :- في زر الترحيل الى القاعدة الأولى استخدم الكود التالي :- Private Sub COM1_Click() On Error GoTo ErrorHandler Dim db1 As DAO.Database Dim db2 As DAO.Database Dim rst1 As DAO.Recordset Dim rstCheck As DAO.Recordset Dim strSQL As String Dim strCheck As String Dim strPath2 As String Dim intCount As Integer strPath2 = CurrentProject.Path & "\Zakat2.accdb" Set db1 = CurrentDb Set db2 = DBEngine.OpenDatabase(strPath2) strCheck = "SELECT COUNT(*) AS NewCount " & _ "FROM TBInvoiceMain " & _ "WHERE ID NOT IN " & _ "(SELECT ID FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2)" Set rstCheck = db1.OpenRecordset(strCheck) If Not rstCheck.EOF Then If rstCheck!NewCount = 0 Then MsgBox "لا توجد فواتير جديدة للترحيل", vbInformation + vbMsgBoxRight, "" GoTo CleanUp End If If MsgBox("سيتم نقل " & rstCheck!NewCount & " فاتورة . هل تريد المتابعة؟", _ vbQuestion + vbMsgBoxRight + vbYesNo, "") = vbNo Then GoTo CleanUp End If End If strSQL = "SELECT DISTINCT TBInvoiceMain.* " & _ "FROM TBInvoiceMain " & _ "WHERE InvoiceNumber NOT IN " & _ "(SELECT InvoiceNumber FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2)" Set rst1 = db1.OpenRecordset(strSQL) intCount = 0 If Not rst1.EOF Then Do While Not rst1.EOF On Error Resume Next strSQL = "INSERT INTO [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "SELECT ID, ID2, InvoiceNumber, FormNumber, InvoiceType, UUID, " & _ "InvoiceSerial, InvoiceDate, InvoiceTime, InvoiceTypeCodeID, " & _ "InvoiceTypeCodeName, InvoiceHash, DateSupply, EndDateSupply, " & _ "PaymentMethod, InstructionNote, TotalDiscount, DiscountReason, " & _ "TaxCode, TaxCodeName, TaxPercentage, InvoiceQR, InvoiceXmlName, " & _ "InvoiceXmlFullPath, EncodedInvoice, XMLCreated, SendingStatus, " & _ "ZatcaStatusCode, ZatcaXMLSent, ZatcaWarningMessage, ZatcaErrorMessage, " & _ "ClearedInvoice, BuyerStreetName, BuyerAdditionalStreetName, " & _ "BuyerBuildingNumber, BuyerPlotIdEntification, BuyerCityName, " & _ "BuyerPostalCode, BuyerCountrySubEntity, BuyerCitySubDivisionName, " & _ "BuyerCompanyName, BuyerTaxNumber, clearedXmlFullPath, BuyerCommercialRegistrationNo " & _ "FROM TBInvoiceMain WHERE InvoiceNumber = " & rst1!InvoiceNumber db1.Execute strSQL If Err.Number = 0 Then strSQL = "INSERT INTO [;DATABASE=" & strPath2 & "].TBInvoiceSub2 " & _ "SELECT ID, InvoiceNumber, ItemName, Quantity, ItemPriceBeforeTax, " & _ "TaxPercentage, TaxCode, Discount " & _ "FROM TBInvoiceSub WHERE InvoiceNumber = " & rst1!InvoiceNumber db1.Execute strSQL If Err.Number = 0 Then intCount = intCount + 1 End If End If On Error GoTo ErrorHandler rst1.MoveNext Loop strSQL = "DELETE TBInvoiceSub.* " & _ "FROM TBInvoiceSub INNER JOIN TBInvoiceMain ON TBInvoiceMain.ID = TBInvoiceSub.ID " & _ "WHERE DateDiff('d', TBInvoiceMain.InvoiceDate, Date()) > 30" db1.Execute strSQL strSQL = "DELETE TBInvoiceMain.* " & _ "FROM TBInvoiceMain " & _ "WHERE DateDiff('d', InvoiceDate, Date()) > 30" db1.Execute strSQL If intCount > 0 Then MsgBox "تم ترحيل " & intCount & " فاتورة بنجاح" & vbCrLf & _ "وتم حذف الفواتير الأقدم من 30 يوم", vbInformation + vbMsgBoxRight, "" Else MsgBox "لم يتم ترحيل أي فواتير", vbInformation + vbMsgBoxRight, "" End If End If CleanUp: If Not rst1 Is Nothing Then rst1.Close If Not rstCheck Is Nothing Then rstCheck.Close Set rst1 = Nothing Set rstCheck = Nothing If Not db2 Is Nothing Then db2.Close Set db2 = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء عملية الترحيل", vbCritical + vbMsgBoxRight, "" Resume CleanUp End Sub أما في نموذج استرجاع رقم فاتورة محدد ، استخدم الكود التالي :- Private Sub COM1_Click() On Error GoTo ErrorHandler If IsNull(Me.Text1) Or Trim(Me.Text1) = "" Then MsgBox "الرجاء إدخال رقم الفاتورة المطلوب استرجاعها", vbExclamation + vbMsgBoxRight, "" Me.Text1.SetFocus Exit Sub End If If Not IsNumeric(Me.Text1) Then MsgBox "الرجاء إدخال رقم فاتورة صحيح", vbExclamation + vbMsgBoxRight, "" Me.Text1.SetFocus Exit Sub End If Dim db1 As DAO.Database Dim db2 As DAO.Database Dim rst1 As DAO.Recordset Dim strSQL As String Dim strPath2 As String Dim lngInvoiceNumber As Long strPath2 = CurrentProject.Path & "\Zakat2.accdb" lngInvoiceNumber = CLng(Trim(Me.Text1)) Set db1 = CurrentDb Set db2 = DBEngine.OpenDatabase(strPath2) strSQL = "SELECT COUNT(*) AS InvCount " & _ "FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "WHERE InvoiceNumber = " & lngInvoiceNumber Set rst1 = db1.OpenRecordset(strSQL) If rst1!InvCount = 0 Then MsgBox "الفاتورة رقم " & lngInvoiceNumber & " غير موجودة في قاعدة البيانات الثانية", vbExclamation + vbMsgBoxRight, "" GoTo CleanUp End If strSQL = "SELECT COUNT(*) AS InvCount FROM TBInvoiceMain " & _ "WHERE InvoiceNumber = " & lngInvoiceNumber Set rst1 = db1.OpenRecordset(strSQL) If rst1!InvCount > 0 Then If MsgBox("الفاتورة موجودة بالفعل في القاعدة الحالية . هل تريد استرجاعها مرة أخرى؟", _ vbQuestion + vbYesNo + vbMsgBoxRight, "") = vbNo Then GoTo CleanUp End If End If strSQL = "INSERT INTO TBInvoiceMain " & _ "SELECT * FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "WHERE InvoiceNumber = " & lngInvoiceNumber db1.Execute strSQL strSQL = "INSERT INTO TBInvoiceSub " & _ "SELECT * FROM [;DATABASE=" & strPath2 & "].TBInvoiceSub2 " & _ "WHERE InvoiceNumber = " & lngInvoiceNumber db1.Execute strSQL MsgBox "تم استرجاع الفاتورة رقم " & lngInvoiceNumber & " بنجاح", vbInformation + vbMsgBoxRight, "" Me.Text1 = "" Me.Text1.SetFocus CleanUp: If Not rst1 Is Nothing Then rst1.Close Set rst1 = Nothing If Not db2 Is Nothing Then db2.Close Set db2 = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء عملية الاسترجاع", vbCritical + vbMsgBoxRight, "" Resume CleanUp End Sub تم الإعتماد هنا على رقم الفاتورة من الحقل InvoiceNumber ، وأخبرني بالنتيجة . المرفق بعد التعديل .. Zakat.zip .

استاذ @سلمان الشهراني ممكن استخدام هذه الفكرة كما بالمرفق لكن ماينفع معها علاقات . جرب زياد ادخالات .ووافني بالرد . Zakat-1.rar

كل ترحيل عبارة عن مجموعة من السجلات .. يتم لاحقا حذفها جملة بزر بامر واحد .. راجع مشاركتي السابقة جيدا من اجل هذا كتبت رؤيتي حول العملية .. حول نقطتين او اجرائين في فكرتك الأصلية : 1- المقارنة بين السجلات في قاعدتين متباعدتين 1- الحذف الآلي

جزيت خيرا ابا جودي الحقيقة انه اي ملف من ميكروسوفت اقوم بتنزيله _اذا غير مضغوط _ اضطر الى فتح خصائص هذا الملف واعطل هذا الحظر