kanory

اهلا بك اخي احمد لا عليك ... مرحبابك المهم انك وجدت مطلوبك اخي الكريم

اختصارا للوقت ...... جرب المرفق التالي ..... يتم تكوين جدول بالمواد مهما كان عددها في الجدول <><><><><><><><><><><><> KAN_2.accdb

طيب ::::: - كل المجالات في جدول واحد .... بمعني ممكن يكون في الحقل مثلا مادة1 ((اللغة العربية) و (اللغة الانجليزية)) يعني طالب من مجال واخر من مجال اخر ممكن جدول فيه اكثر من مجال اذا كانت المجالات كلها في جدول واحد ... الموجود الان فقط مجال واحد وهو استصلاح الاراضى الصحراوية والميكنة الزراعية حتى نعاين شكل الجدول

الاجابة نعم ........ ولكن اسماء الحقول ( حقول المواد ) هل المرفقة في بداية موضوعك أم هي حقول مجازية وعند التطبيق على مثالك يتوقف الكود الذي نكتبه لك دائما اذكر كل تفاصيل برنامجك حتى لاتقع في الحرج مثل ما فعلت ...... اردت تطبيق المرفق بعد الاجابة على برنامجك فوجدت ان برنامجك يحوى اسماء مواد اخرى وحقول اكثر قبل الاجابة على سؤالك :::: هل جميع جقول المواد لديك تبدا مادة ثم رقم أم ماذا ؟؟؟؟؟؟؟؟؟؟؟؟

تفضل KAN_1.accdb

تفضل جرب المرفق KAN_1.accdb

بارك الله فيك فكرة جيدة .... عند الضغط والاصلاح يفقد الحماية ..... هل جربت الضغط على مفتاح Alt+F11

مشاركة مع الحبايب

في اعلا النموذج لديك ضع دالة Sleep لانها غير موجودة لديك #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If

طيب استخرج المجلد بجوار القاعدة ثم استخدم هذا الكود Sub ExportReports_To_OnePDF_PDFtk() Dim arrReports As Variant Dim i As Integer Dim strTempFolder As String Dim strFinalPDF As String Dim strPDFtk As String Dim strCmd As String strPDFtk = CurrentProject.Path & "\PdftkBuilderPortable\pdftk.exe" strTempFolder = CurrentProject.Path & "\TempPDF\" strFinalPDF = CurrentProject.Path & "\AllReports.pdf" arrReports = Array("rpt1", "rpt2", "rpt3") If Dir(strTempFolder, vbDirectory) = "" Then MkDir strTempFolder End If If Dir(strTempFolder & "*.pdf") <> "" Then Kill strTempFolder & "*.pdf" End If For i = LBound(arrReports) To UBound(arrReports) DoCmd.OutputTo acOutputReport, arrReports(i), acFormatPDF, _ strTempFolder & (i + 1) & "_" & arrReports(i) & ".pdf", False Next i strCmd = """" & strPDFtk & """ " & _ """" & strTempFolder & "*.pdf"" cat output " & _ """" & strFinalPDF & """" Shell strCmd, vbHide MsgBox "تم إنشاء ملف PDF واحد بنجاح ?" & vbCrLf & strFinalPDF, vbInformation Kill strTempFolder & "*.pdf" End Sub PdftkBuilderPortable.rar

استتخدم هذا مع تعدي اسماء التقارير في المصفوفة Sub Export_All_Reports_To_OnePDF() Dim arrReports As Variant Dim i As Integer Dim strFile As String ' أسماء التقارير بالترتيب المطلوب arrReports = Array("Q", "Report2", "Report3") strFile = CurrentProject.Path & "\AllReports.pdf" ' فتح التقارير (مخفية) For i = LBound(arrReports) To UBound(arrReports) DoCmd.OpenReport arrReports(i), acViewPreview, , , acHidden Next i ' دمج وتصدير في ملف واحد DoCmd.OutputTo acOutputReport, arrReports(0), acFormatPDF, strFile, False ' إغلاق التقارير For i = LBound(arrReports) To UBound(arrReports) DoCmd.Close acReport, arrReports(i), acSaveNo Next i MsgBox "تم إنشاء الملف بنجاح", vbInformation End Sub

انشأ مديول وضع فيه هذا Public Sub FillBookmark(BMName As String, BMValue As String) Dim rng As Object If Objwrd.ActiveDocument.Bookmarks.Exists(BMName) Then Set rng = Objwrd.ActiveDocument.Bookmarks(BMName).Range rng.Text = BMValue Objwrd.ActiveDocument.Bookmarks.Add BMName, rng Else MsgBox "Bookmark غير موجود: " & BMName, vbExclamation End If End Sub ثم استخدم هذا في الزر لديك جرب واعلمنا بالنتيجة Private Sub أمر0_Click() On Error GoTo Err_Handler 'فتح ملف الوورد OpenClsword (CurrentProject.Path & "\123.doc") 'تعبئة الـ Bookmarks بدون تكرار Call FillBookmark("AA", txtYear) Call FillBookmark("A1", Format(tx1, "#,##0.00")) Call FillBookmark("A2", Format(tx2, "#,##0.00")) Call FillBookmark("A3", Format(tx3, "#,##0.00")) Call FillBookmark("A4", Format(tx4, "#,##0.00")) Call FillBookmark("A5", Format(tx5, "#,##0.00")) Call FillBookmark("A6", Format(tx6, "#,##0.00")) Call FillBookmark("A7", Format(tx7, "#,##0.00")) Call FillBookmark("A8", Format(tx8, "#,##0.00")) Call FillBookmark("A9", Format(tx9, "#,##0.00")) Exit Sub Err_Handler: MsgBox "حدث خطأ أثناء التصدير إلى الوورد", vbCritical End Sub

هل تريد تصدير هذه التقارير في ملف واحد ام ملفات متعددة

لما لا تستخدم مسح البيانات القديمة وادراج الجديد

استبدل الكود بهذا <><><><><><><> Private Sub أمر0_Click() On Error Resume Next OpenClsword (CurrentProject.Path & "\123.doc") Objwrd.ActiveDocument.Bookmarks("AA").Select Objwrd.Selection.InsertAfter txtYear Objwrd.ActiveDocument.Bookmarks("A1").Select Objwrd.Selection.InsertAfter Format(tx1, "#,##0.00") Objwrd.ActiveDocument.Bookmarks("A2").Select Objwrd.Selection.InsertAfter Format(tx2, "#,##0.00") Objwrd.ActiveDocument.Bookmarks("A3").Select Objwrd.Selection.InsertAfter Format(tx3, "#,##0.00") Objwrd.ActiveDocument.Bookmarks("A4").Select Objwrd.Selection.InsertAfter Format(tx4, "#,##0.00") Objwrd.ActiveDocument.Bookmarks("A5").Select Objwrd.Selection.InsertAfter Format(tx5, "#,##0.00") Objwrd.ActiveDocument.Bookmarks("A6").Select Objwrd.Selection.InsertAfter Format(tx6, "#,##0.00") Objwrd.ActiveDocument.Bookmarks("A7").Select Objwrd.Selection.InsertAfter Format(tx7, "#,##0.00") Objwrd.ActiveDocument.Bookmarks("A8").Select Objwrd.Selection.InsertAfter Format(tx8, "#,##0.00") Objwrd.ActiveDocument.Bookmarks("A9").Select Objwrd.Selection.InsertAfter Format(tx9, "#,##0.00") End Sub