kanory

كلامك وكلام الزملاء صحيح عند اتباع الخطوات الصحيحة وخاصة الجداول تسهل عملية ادخال واخراج البيانات بارك الله فيكم استاذ @ابوخليل

يا اخي الكود شغال لدي ولم ارفق الملف الا بعد التجربة دون جدوى ... طيب وضح هل هناك رسالة ظهرت لديك .... وهل الملف بعد فتحه طلب عملية تمكين ..؟؟؟؟؟؟؟؟؟؟

تفضل ....................... ‏‏القرآن الكريم 2.accdb

استخدم هذه الشيفرى Private Sub Command30_Click() Dim rs As DAO.Recordset With Forms("القرآن الكريم") Set rs = .RecordsetClone rs.FindFirst "SurahNo = 1" ' عدّل القيمة حسب ما تريد البحث عنه If Not rs.NoMatch Then .Bookmark = rs.Bookmark Else MsgBox "لم يتم العثور على السورة المطلوبة.", vbExclamation End If End With End Sub Private Sub Command33_Click() Dim rs As DAO.Recordset With Forms("القرآن الكريم") Set rs = .RecordsetClone rs.FindFirst "SurahNo = " & Me![SurahNo] + 1 If Not rs.NoMatch Then .Bookmark = rs.Bookmark Else MsgBox "لم يتم العثور على السورة السابقة.", vbExclamation End If End With End Sub Private Sub Command34_Click() Dim rs As DAO.Recordset With Forms("القرآن الكريم") Set rs = .RecordsetClone rs.FindFirst "SurahNo = " & Me![SurahNo] - 1 If Not rs.NoMatch Then .Bookmark = rs.Bookmark Else MsgBox "لم يتم العثور على السورة السابقة.", vbExclamation End If End With End Sub Private Sub Command35_Click() Dim rs As DAO.Recordset With Forms("القرآن الكريم") Set rs = .RecordsetClone rs.FindFirst "SurahNo = 114" ' عدّل القيمة حسب ما تريد البحث عنه If Not rs.NoMatch Then .Bookmark = rs.Bookmark Else MsgBox "لم يتم العثور على السورة المطلوبة.", vbExclamation End If End With End Sub طبعا التعديل على المثال الاول الذي اوردته انت

طلبك غريب شوي ,,,,,, لكن استخدم هذه الاكواد ............................... Private Sub Form_Load() Dim db As DAO.Database Dim obj As AccessObject Dim strPath As String Dim strFile As String Dim RowSource As String ' إضافة النماذج الموجودة (مع استثناء نموذج "main") Set db = CurrentDb For Each obj In CurrentProject.AllForms If LCase(obj.Name) <> "main" Then RowSource = RowSource & "نموذج:" & obj.Name & ";" End If Next obj ' البحث عن ملفات إكسل في نفس مسار قاعدة البيانات strPath = CurrentProject.Path & "\" strFile = Dir(strPath & "*.xlsx*") ' يشمل xls و xlsx Do While strFile <> "" RowSource = RowSource & "ملف:" & strFile & ";" strFile = Dir Loop ' تحديث مصدر الصفوف لمربع التحرير والسرد If Right(RowSource, 1) = ";" Then RowSource = Left(RowSource, Len(RowSource) - 1) End If Me.مربع_تحرير_وسرد1.RowSourceType = "Value List" Me.مربع_تحرير_وسرد1.RowSource = RowSource End Sub Private Sub مربع_تحرير_وسرد1_AfterUpdate() Dim selectedItem As String selectedItem = Me.مربع_تحرير_وسرد1.Value If Left(selectedItem, 6) = "نموذج:" Then DoCmd.OpenForm Mid(selectedItem, 7) ElseIf Left(selectedItem, 4) = "ملف:" Then Dim filePath As String filePath = CurrentProject.Path & "\" & Mid(selectedItem, 5) Dim xlApp As Object On Error Resume Next Set xlApp = CreateObject("Excel.Application") On Error GoTo 0 If Not xlApp Is Nothing Then xlApp.Visible = True xlApp.Workbooks.Open filePath Else MsgBox "تعذر تشغيل Microsoft Excel.", vbExclamation End If End If End Sub

اخي ريان نحاول المساعدة ولكنك لم تكلف نفسك بادراج ملف PDF الموجود لديك لنرى التصميم لديك ولا قاعدة بياناتك ( انت ادرجت لنا مرة اخرى قاعدة بيانات الاستاذ @kkhalifa1960 لنقل بيانات من الاكسس الى PDF : اولا يجب ان يكون لديك برنامج برنامج Adobe Acrobat Pro (وليس Adobe Reader فقط) او برنامج PDFtk ثانيا ملف PDF يجب ان يكون استمارة فردية اي لعرض بيانات فردية وليس نموذج مستمر كما ارفقت انت في مثال اخونا خليفة ثالثا تفعيل المرجع Adobe Acrobat xx.x Type Library (xx = رقم الإصدار مثل 10.0 أو 11.0) رابعا يجب أن يحتوي ملف الـ PDF على الحقول المسماة مثلا : وهذه يم اضافتها عن طريق البرامج المذكورة في اولا "Text1" "Dropdown2" "todaysDate" خامسا استخدام هذه الشيفرة اذا كان البرنامج المستخدم PDFtk ::::::::::::::::::::::::: Sub FillPDF() Dim tempFDF As String Dim pdfInput As String Dim pdfOutput As String Dim shellCmd As String Dim fso As Object Dim fdfContent As String Dim pdftkPath As String Dim appPath As String ' تحديد مسار البرنامج الحالي (نفس مجلد قاعدة البيانات أو ملف الإكسل) appPath = Application.CurrentProject.Path ' Access ' إذا كنت تستخدم Excel بدلاً من Access، استبدل بالسطر التالي: ' appPath = ThisWorkbook.Path ' تحديد مسار الملفات pdfInput = appPath & "\template.pdf" ' اسم ملف PDF بجانب الملف pdfOutput = appPath & "\output_filled.pdf" ' ملف الإخراج بجانب الملف tempFDF = appPath & "\temp_data.fdf" ' ملف FDF مؤقت ' مسار برنامج PDFtk pdftkPath = """C:\Program Files (x86)\PDFtk Server\bin\pdftk.exe""" ' تحضير محتوى FDF fdfContent = "%FDF-1.2" & vbCrLf fdfContent = fdfContent & "1 0 obj<</FDF<< /Fields[" & _ "<< /T (Text1) /V (" & Me.Text0.Value & ") >>" & _ "<< /T (Dropdown2) /V (" & Me.Text2.Value & ") >>" & _ "<< /T (todaysDate) /V (" & Me.Text4.Value & ") >>" & _ "] >> >>endobj" & vbCrLf fdfContent = fdfContent & "trailer<</Root 1 0 R>>" & vbCrLf fdfContent = fdfContent & "%%EOF" ' إنشاء ملف FDF Set fso = CreateObject("Scripting.FileSystemObject") With fso.CreateTextFile(tempFDF, True) .Write fdfContent .Close End With ' تنفيذ الأمر باستخدام PDFtk shellCmd = pdftkPath & " """ & pdfInput & """ fill_form """ & tempFDF & """ output """ & pdfOutput & """ flatten" Shell shellCmd, vbHide MsgBox "تم إنشاء الملف: " & pdfOutput End Sub سادسا استخدام هذه الشيفرة اذا كان البرنامج المستخدم Adobe Acrobat Pro ::::::::::::::::::::::::: Dim AcroApp As Acrobat.CAcroApp Dim theForm As Acrobat.CAcroPDDoc Dim jso As Object Dim path As String Dim field As Object Dim Text1, Dropdown2, todaysDate As String Dim Text0, Text2, Text4 As String Set AcroApp = CreateObject("AcroExch.App") Set theForm = CreateObject("AcroExch.PDDoc") theForm.Open (Me.Label16.Caption) Set jso = theForm.GetJSObject 'write the values to corresponding pdf fields jso.getfield("Text1").Value = Me.Text0.Value jso.getfield("Dropdown2").Value = Me.Text2.Value jso.getfield("todaysDate").Value = Me.Text4.Value theForm.Save PDSaveIncremental, Me.Label16.Caption theForm.Close AcroApp.Exit Set AcroApp = Nothing Set theForm = Nothing سابعا ::: انا دوري انتهى هنا بارك الله فيك

هل البيانات المنقولة باللغة الانجليزية ام العربية وهل ممكن مرفق كمثال للتطبيق عليه

اخي @ابو عارف وعليكم السلام ورحمة الله وبركاته .... تقبل الله منا ومنكم صالح الاعمال في اذا كنت قصد الطباعة جرب هذا الكود ..... Sub PrintReportPages() Dim rptName As String Dim startPage As Integer Dim endPage As Integer ' اسم التقرير rptName = "اسم_التقرير" ' تحديد نطاق الصفحات startPage = 2 endPage = 5 ' فتح التقرير في وضع المعاينة DoCmd.OpenReport rptName, acViewPreview ' طباعة الصفحات المحددة DoCmd.PrintOut acPages, startPage, endPage ' إغلاق التقرير بعد الطباعة DoCmd.Close acReport, rptName End Sub

اخي الكريم ليس لدي حل والسبب ارقام id ترقيم تلقائي وهناك جداول عديدة مرتبطة بها ... اعتذر لك في عدم حل مشكلتك ... ربما تجد حلا من قبل بعض الاعضاء ...

اخي محمد هل هناك جداول أخرى مرتبطة برقم id غير الجدولين الموجودين في المثال وهل لو تم تغيير الرقم تتأثر بذلك بيانات أخرى في جداول أخرى ام لا .... لان الربط بحقل ترقيم تلقائي هذه واحدة من مشاكله .

هل جربت التجميع

طيب حبه حبه الان كريمو٦٧ أليس دافع للانخراط من خلال الصورة الأولى ... لاحظ الصورة الاولى

انظر لهذا العامل تم دفع الانخراط .... وانت طالب في موضوع سابق ان يتم تجاوز العامل الذي دفع 3000 لذلك تم تجاوزهم من دفع الانخراط

ممكن توضيح اكثر يعني هل تريد اقتصاص الصورة من البطاقة نفسها وهل ممكن مثال

كلنا ذاك الرجل ..... امين ....

وعليكم السلام ورحمة الله وبركاته اخي @ابوخليل انظر هذا الموضوع قد يفيدك

جرب هذا الكود .............. Sub UpdateRecords() Dim db As DAO.Database Dim strSQL As String ' تعيين قاعدة البيانات الحالية Set db = CurrentDb ' تحديث حقل ITEM_PRES_DK (إزالة 0. والاحتفاظ فقط بالرقم بعد العلامة العشرية) strSQL = "UPDATE TAEBOL_TEST SET ITEM_PRES_FK = ITEM_PRES_FK * 10 WHERE ITEM_PRES_FK < 1;" db.Execute strSQL, dbFailOnError ' تحديث حقل النسبة (إضافة % إلى الرقم) strSQL = "UPDATE TAEBOL_TEST SET NASBA_2 = NASBA_2 & '%';" db.Execute strSQL, dbFailOnError ' تحرير الذاكرة Set db = Nothing MsgBox "تم تحديث السجلات بنجاح!", vbInformation End Sub

وعليكم السلام ورحمة الله جرب الكود التالي Sub UpdateSerialNumbers() Dim db As DAO.Database Dim sql As String Dim currentYear As String ' الحصول على السنة الحالية من نظام الكمبيوتر currentYear = Year(Date) ' إنشاء استعلام التحديث sql = "UPDATE [أرقام مسلسلة] " & _ "SET مسلسل = Left(مسلسل, InStr(مسلسل, '/') - 1) & '/" & currentYear & "'" ' فتح قاعدة البيانات وتنفيذ الاستعلام Set db = CurrentDb db.Execute sql, dbFailOnError ' تنظيف الذاكرة Set db = Nothing ' إظهار رسالة تأكيد MsgBox "تم تحديث أرقام المسلسل إلى سنة " & currentYear, vbInformation, "تحديث ناجح" End Sub شرح الكود: يحصل على السنة الحالية من النظام. ينشئ استعلام تحديث يستبدل الجزء الأيمن (/2024) بالسنة الجديدة. يستخدم دالة Left() لاستخراج الجزء الأيسر من السلسلة النصية قبل العلامة /، ثم يضيف /السنة الجديدة. ينفذ التحديث عبر db.Execute. يعرض رسالة تأكيد بعد انتهاء العملية. طريقة الاستخدام: يمكنك تشغيل هذا الكود من خلال زر في نموذج، بإضافة زر وتنفيذ الإجراء عند النقر عليه. أو تشغيله يدويًا من نافذة VBA. طريقة استخدام الكود انشئ زر وضع فيه Call UpdateSerialNumbers

كفكرة اجعل عملية التفعيل عند طريق الانترنت ومحددة الفترة الزمنية ويتوقف البرنامج خلالها ويجب على العميل طلب التفعيل لفترة اخرى او مدى الحياة

لو استخدمت البحث في المنتدى تجد ما يسرك وهذا أحد الموضوعات

بعد نسخ الشيفرة ولصقها في النموذج لديك استدعي كود الفتح بهذه الصورة Private Sub Compact_Click() Dim path As String path = "E:\Auto\ddbee$" ' مسار قاعدة البيانات call CompactAndRepairDatabase Shell "MSACCESS.EXE " & path, vbNormalFocus End Sub

اولا هل تقوم بإجراء نسخ احتياطية لبياناتك قبل الضغط والإصلاح لان لاي سبب حصل خطأ قد تفقد بياناتك ... على كل حال هذه الشيفرة تقوم باللازم اقصد الضغط والإصلاح Sub CompactAndRepairDatabase() Dim dbPath As String Dim tempDbPath As String ' المسار الكامل لقاعدة البيانات الأصلية dbPath = "E:\Auto\dbbee.accdb" ' إنشاء مسار مؤقت لقاعدة البيانات بعد الإصلاح tempDbPath = "E:\Auto\dbbee_temp.accdb" ' تأكد من أن قاعدة البيانات الأصلية موجودة If Dir(dbPath) <> "" Then ' إجراء عملية Compact and Repair On Error Resume Next Application.CompactRepair SourceFile:=dbPath, DestinationFile:=tempDbPath, LogFile:=False If Err.Number = 0 Then ' استبدال قاعدة البيانات الأصلية بالنسخة الجديدة Kill dbPath ' حذف قاعدة البيانات الأصلية Name tempDbPath As dbPath ' إعادة تسمية النسخة المؤقتة إلى الأصلية MsgBox "تم إصلاح قاعدة البيانات بنجاح!", vbInformation Else MsgBox "حدث خطأ أثناء الإصلاح: " & Err.Description, vbCritical End If On Error GoTo 0 Else MsgBox "قاعدة البيانات غير موجودة في المسار المحدد!", vbExclamation End If End Sub

دالة DoCmd.OpenDataAccessPage تُستخدم لفتح صفحات الوصول إلى البيانات (Data Access Pages) وليس لفتح قاعدة بيانات خارجية. لفتح قاعدة بيانات أخرى، يمكنك استخدام دالة Application.OpenCurrentDatabase أو دالة Shell Application.OpenCurrentDatabase "E:\Auto\dbbee.accdb" إذا كنت تريد تشغيل قاعدة البيانات كملف منفصل باستخدام Shell Dim path As String path = "E:\Auto\dbbee.accdb" ' مسار قاعدة البيانات Shell "MSACCESS.EXE " & path, vbNormalFocus

دائما ابحث عن حل كامل لمشاكل برامجك .... لا ترضي بانصاف الحلول ..... لو عرضت لنا تلك المسميات لربما تجد الحل من احد اعضاء المنتدى فيصبح لديك حل 100 % تفضل انظر الجدول .. ليس فيه مسارات .... وانظر الى مجلد الصور فيه الصور باسماء ارقام تلك السجلات فقط ... ولكن تحتاج الى تعديل زر الاضافة والحذف لم يسمح وقتي بذلك التعديل 555.rar

ممكن الاستغناء عن إضافة المسارات في الجدول ويتم عرضها من المجلد مباشرة بمعرفة الرقم فقط