كل الانشطه

وردا على الرد المخفى يا فؤش واللى مش فاهم انت خفيته ليه انا عجبتنى الافكار بس اضفت بعض البهارات للطبخة اتمنى لكم مذاقا هنيئا Option Compare Database Option Explicit Public DebugMode As Boolean Public Sub ExportImagesToPdf( _ Optional blnShowImageNames As Boolean = True, _ Optional blnAddPageNumbers As Boolean = True, _ Optional strPdfName As String = "", _ Optional strFolderSource As String = "", _ Optional strFolderTarget As String = "" _ ) Dim strPdfPath As String Dim objFSO As Object, objFolder As Object, objFile As Object Dim objWordApp As Object, objDoc As Object, objRange As Object, objImg As Object Dim colFiles As Collection, arrFiles() As String Dim lngImgCount As Long, i As Long Dim fd As Object On Error GoTo ErrHandler ' اختيار مجلد الصور إذا لم يُمرر If Trim(strFolderSource) = "" Then Set fd = Application.FileDialog(4) With fd .Title = "اختر المجلد الذي يحتوي على الصور" If .Show <> -1 Then If DebugMode Then Debug.Print "تم إلغاء اختيار مجلد الصور." Exit Sub End If strFolderSource = .SelectedItems(1) End With End If If Right(strFolderSource, 1) <> "\" Then strFolderSource = strFolderSource & "\" If DebugMode Then Debug.Print "مجلد الصور: " & strFolderSource ' التحقق من وجود مجلد الصور If Dir(strFolderSource, vbDirectory) = "" Then MsgBox "مجلد الصور غير موجود", vbCritical + vbMsgBoxRight Exit Sub End If ' اختيار مجلد الهدف إذا لم يُمرر If Trim(strFolderTarget) = "" Then Set fd = Application.FileDialog(4) With fd .Title = "اختر المجلد لحفظ ملف PDF" If .Show <> -1 Then If DebugMode Then Debug.Print "تم إلغاء اختيار مجلد الهدف." Exit Sub End If strFolderTarget = .SelectedItems(1) End With End If If Right(strFolderTarget, 1) <> "\" Then strFolderTarget = strFolderTarget & "\" If Dir(strFolderTarget, vbDirectory) = "" Then MkDir strFolderTarget If DebugMode Then Debug.Print "تم إنشاء مجلد الهدف: " & strFolderTarget End If ' إعداد اسم ملف PDF If Trim(strPdfName) = "" Then strPdfPath = strFolderTarget & "صور_المجلد_" & Format(Now(), "yyyy-mm-dd_hh-mm-ss") & ".pdf" Else strPdfPath = strFolderTarget & strPdfName & ".pdf" End If If DebugMode Then Debug.Print "مسار ملف PDF: " & strPdfPath ' جمع الصور Set colFiles = New Collection Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(strFolderSource) For Each objFile In objFolder.Files If LCase(objFile.Name) Like "*.jpg" Or LCase(objFile.Name) Like "*.jpeg" Or _ LCase(objFile.Name) Like "*.png" Or LCase(objFile.Name) Like "*.bmp" Or _ LCase(objFile.Name) Like "*.gif" Then colFiles.Add objFile.Path lngImgCount = lngImgCount + 1 If DebugMode Then Debug.Print "تم العثور على صورة: " & objFile.Path End If Next If lngImgCount = 0 Then MsgBox "لا توجد صور في المجلد المحدد", vbExclamation + vbMsgBoxRight GoTo CleanExit End If ' تحويل الـ Collection إلى مصفوفة ReDim arrFiles(0 To lngImgCount - 1) For i = 1 To colFiles.Count arrFiles(i - 1) = colFiles(i) Next ' فرز الصور Call SortArray(arrFiles) If DebugMode Then Debug.Print "تم فرز الصور" ' إنشاء مستند Word Set objWordApp = CreateObject("Word.Application") Set objDoc = objWordApp.Documents.Add objWordApp.Visible = False With objDoc.PageSetup .Orientation = 0 .TopMargin = 28 .BottomMargin = 28 .LeftMargin = 28 .RightMargin = 28 End With ' إضافة ترقيم الصفحات (إذا تم اختياره) If blnAddPageNumbers Then With objDoc.Sections(1).Footers(1).PageNumbers .Add 1, True .NumberStyle = 0 ' wdNumberStyleArabic With .Parent.Range .ParagraphFormat.Alignment = 1 ' توسيط .Font.Size = 8 .Font.Color = RGB(100, 100, 100) End With End With End If ' إدراج الصور For i = 0 To UBound(arrFiles) Set objRange = objDoc.Range objRange.Collapse 0 If i > 0 Then objRange.InsertBreak 2 objRange.Collapse 0 End If ' إدراج الصورة objRange.ParagraphFormat.Alignment = 1 Set objImg = objRange.InlineShapes.AddPicture(arrFiles(i), False, True) With objImg .LockAspectRatio = True If .Width > 500 Or .Height > 650 Then If .Width / .Height > 500 / 650 Then .Width = 500 Else .Height = 650 End If End If End With ' إضافة اسم الملف أسفل الصورة (إذا تم اختياره) If blnShowImageNames Then Set objRange = objDoc.Range objRange.Collapse 0 objRange.InsertAfter vbCrLf & Mid(arrFiles(i), InStrRev(arrFiles(i), "\") + 1) With objRange .ParagraphFormat.Alignment = 1 .ParagraphFormat.SpaceAfter = 6 .Font.Size = 9 .Font.Color = RGB(120, 120, 120) End With End If If DebugMode Then Debug.Print "تم إدراج الصورة: " & arrFiles(i) Next ' حذف أي فقرات فارغة في بداية المستند While objDoc.Paragraphs.Count > 0 And Trim(objDoc.Paragraphs(1).Range.Text) = "" objDoc.Paragraphs(1).Range.Delete Wend ' حذف فقرة فارغة محتملة في النهاية If objDoc.Paragraphs.Count > 0 Then With objDoc.Paragraphs(objDoc.Paragraphs.Count).Range If Trim(.Text) = "" Then .Delete End With End If ' حفظ كـ PDF objDoc.SaveAs2 strPdfPath, 17 objDoc.Close False objWordApp.Quit MsgBox "تم إنشاء ملف PDF بنجاح:" & vbCrLf & strPdfPath, vbInformation + vbMsgBoxRight CleanExit: Set objDoc = Nothing Set objWordApp = Nothing Set objRange = Nothing Set objImg = Nothing Set colFiles = Nothing Set objFolder = Nothing Set objFSO = Nothing Set fd = Nothing Exit Sub ErrHandler: If DebugMode Then Debug.Print "خطأ: " & Err.Number & " - " & Err.Description End If MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight Resume CleanExit End Sub Private Sub SortArray(ByRef arr() As String) Dim i As Long, j As Long Dim temp As String For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If UCase(arr(i)) > UCase(arr(j)) Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Next j Next i End Sub

كل التقدير والاحترام لحظرتك اخي الكريم (منتصر الانسي) هذا بالضيط المطلوب وفقك الله ودمت بالف خير

تحية طيبة أخي @Foksh القاعدة الأصلية التي أعمل عليها مشابهة لهذه تقريبا فقط اختصرت بعض الحقول - المبدأ العام هكذا فقط قمت بتغيير : حجم الحقل - التنسيق - المنازل العشرية * كما في الصورة المرفقة 1 * ليصبح بنفس ما هو ما جود في القاعدة الأصلية * المشكل مزال يظهر كما في الصورة المرفقة 2 لو سمحت أرفقت القاعدة المعدلة للتجريب عليها(للمرة الأخيرة حتى لا أثقل عليك أشغلك كثيرا فقط بهذا الموضوع ) وإن اشتغلت عندك فالمشكل على مستواي فجزاك الله كل الخير أخي ,استاذنا @Foksh -آميـــــــن كما أتوجه بالشكر والإمتنان لمعلمنا الجليل @ابوخليل جزاه الله كل الخير - آميــــــن baseM10.accdb

حل رائع للاستاذ/ محمد إليك حل آخر بالأكواد مع اظهار الكلمات المكررة وعددها الاقتباس 2.xlsm

يمكنك تجربة هذه المعادلة =SUMPRODUCT(--ISNUMBER(SEARCH(" " & TRIM(MID(SUBSTITUTE(A2," ",REPT(" ",100)), (ROW(INDIRECT("1:" & LEN(A2)-LEN(SUBSTITUTE(A2," ",""))+1))-1)*100+1, 100)) & " ", " " & $D$2 & " "))) بالتوفيق

أساتذتي الكرام ارجو مساعدتي في دالة أو كود برمجي لحساب عدد الكلمات المكررة والمقتبسة في النص الفرعي من النص الأصلي كما هو موضح في الصورة والملف المرفق ولكم جزيل الشكر الاقتباس.xlsx

نفضل المثال بعد التعديل مثال.rar

استاذي الفاضل Foksh ربي يحفظك يا طيب ممنون من حضرتك جزاك الله خيرا الله يسلمك ويحفظك يارب

ياريت أخ @jjafferr فقد كنت قد أشرت إلى ذلك كون المثال الذي طبقت عليه كان يخص موضوع آخر ولكن الآن أصبح موضوع جديد تماما فمن الأفضل أن يكون موضوع مستقل مع تحياتي

أعتقد أني لم أستوعب الفكرة تماما أو أكون قد فهمت منها ماجعلني أستصعبها صراحة 😅 - هل ستكون قاعدة البيانات هذه فارغة تماما أم ستحتوي على أكواد ستقوم بفتح التطبيق الخاص بنا؟ - هل الإختصار سيكون لقاعدة البيانات الفارغة أم للمجلد ؟ - أكثر عبارة لم أفهمها هي (اضافة ملفات برقة بيضاء شكلا ووهم ان هذه هي القاعدة) فياريت لو توضحي الفكرة بمثال عملي أو فيديو مثل كل مرة مع تحياتي

وتوضيحا فقط وحسب فهمى لقول استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ جعفر - الاكسس يعالج فقط السجلات المعروضة على الشاشة (مثلا 30)؟ صحيح فقط في حالة النماذج (Forms) وغير صحيح في حالة فتح الاستعلام مباشرة أو في التقارير أو التصدير الاكسس ينفذ الاستعلام بالكامل ويحسب النتائج لكل السجلات - إذا كان الاستعلام مصدرا لنموذج فلن يكون هناك بطء ملحوظ؟ صحيح إذا لم تستخدم دوال خارجية في حقول يتم عليها فرز/تصفية لو كان هناك: فرز أو تصفية على حقل فيه دالة DLookup أو دالة VBA خارجية أو تحميل بيانات من جدول كبير بدون فهرسة مناسبة - الطباعة لا تسبب بطء لأنها تطبع صفحة صفحة؟ غير دقيق: الاكسس يقوم بتجهيز التقرير بالكامل قبل عرض أول صفحة أي دوال خارجية أو معادلات تحسب على كل السجلات قبل العرض والطباعة - لا يوجد بطء عند استخدام دوال خارجية إذا لم تكن هناك عمليات فرز أو تصفية؟ صحيح تماما في حالة: استخدام الاستعلام كمصدر نموذج أو عرض النتائج فقط دون فرز/تصفية على الحقول التي تنادي دوال خارجية لكن عند فتح الاستعلام مباشرة أو فرز/تصفية الحقول المحسوبة الاكسس يجبر على حساب القيم لكل السجلات ردودى السابقة لتحليل فهمى لمشاركة الاستاذ جعفر حسب فهمى ومعلوماتى الشخصية وان كان فهمى خاطى أنتظر التصحيح من اساتذتى العظماء

السلام عليكم ورحمة الله وبركاته اخوتي الكرام المطلوب - انشاء استعلام يظهر فيه الاسم الكامل و اعلى (احدث) تاريخ للامر مع رقم الامر . للقاعده المرفقه طيا . مع الشكر والتقدير مقدما مثال.accdb

الاكسس يقوم بحساب السجلات المعروضة على الشاشة فقط عندما يكون ذلك داخل نموذج وليس داخل استعلام هذا حسب فهمى المتواضع قد اكون مخطئ. ربما هذا الظاهر فقط الان ولكن انا دائما مع الاستعلامات اعمل وفق هذه القاعدة الذهبية دائما الأولوية للمنطق المباشر أفضل من الاعتماد على الحيل النصية عند فتح استعلام مباشرة (Query View أو من الكود) Access يقوم بتحميل كل السجلات دفعة واحدة وليس فقط الظاهرة على الشاشة يعني: سواء كان عندك 100 أو 1000,000 سجل وسواء كان حجم الشاشة يعرض 30 فقط او حتى 10 بمجرد فتح الاستعلام مباشرة (من نافذة Access أو من الكود) يقوم Access بتنفيذ الاستعلام بالكامل من البداية إلى النهاية ويحسب ويقوم بمعالجة البيانات فى كل الأعمدة بما فيها الدوال مثل DLookup أو أي دوال خارجية ثم يظهر أول 30 سجل فقط او اول 10 سجلات حسب حجم الشاشة لكن المعالجة تمت لكل السجلات بالفعل

حبيبنا @ابو جودي اقرأ تعليق الأستاذ جعفر هنا 🙂 : وحسب ما يظهر أن الاستعلام هنا لا يتعدى السبع سجلات ، وهي بعدد أيام الأسبوع.

تفضل أخي الكريم ، ما تم هو:- انشاء جدول يحتوي حقل ترقيم تلقائي ( ليس ذا علاقة بالموضوع ، ولكنه عادة ... ) ، وحقل لإضافة المسارات اليه عند اختيارك للصور . ثم إنشاء تقرير مصدره الجدول السابق ، وتم إنشاء عنصر صورة مصدره المربع النصي المرتبط بالحقل الخاص بالمسارات . ثم داخل التقرير لعرض كل صورة في صفحة مستقلة ، في قسم التفاصيل = = تقسيم الصفحات بعد هذا الجزء . وفي نموذج الإفتراضي ، في الزر جعلت لك الأحداث داخل نفس الزر بحيث عند النقر عليه ، تستطيع اختيار الصور التي تريدها ، وبعد الموافقة عليها سيتم فتح التقرير وتصديره الى ملف PDF في المجلد A2 كما طلبت . وهذا من خلال الكود التالي :- Private Sub Command0_Click() Dim fd As Object, selectedFile, db As DAO.Database, rs As DAO.Recordset Dim response As Integer, exportPath As String response = MsgBox("هل تريد حذف السجلات القديمة قبل إضافة الصور الجديدة؟" & vbCrLf & vbCrLf & _ "نعم: لحذف السجلات القديمة أولاً" & vbCrLf & _ "لا: للإبقاء على السجلات القديمة وإضافة الجديدة" & vbCrLf & _ "إلغاء: لإيقاف العملية بالكامل", _ vbQuestion + vbYesNoCancel + vbMsgBoxRight, "خيارات الإضافة") If response = vbCancel Then Exit Sub exportPath = CurrentProject.Path & "\A2\تقرير_الصور_" & Format(Now(), "yyyy-mm-dd_hh-mm-ss") & ".pdf" If Dir(CurrentProject.Path & "\A2", vbDirectory) = "" Then MkDir CurrentProject.Path & "\A2" Set db = CurrentDb() If response = vbYes Then db.Execute "DELETE FROM Tbl_Foksh", dbFailOnError Set fd = Application.FileDialog(3) With fd .Title = "اختر الصور المطلوبة" .AllowMultiSelect = True .Filters.Clear .Filters.Add "ملفات الصور", "*.jpg;*.jpeg;*.png;*.bmp;*.gif" If .Show = -1 Then Set rs = db.OpenRecordset("Tbl_Foksh") For Each selectedFile In .SelectedItems rs.AddNew rs!Pic_Path = CStr(selectedFile) rs.Update Next rs.Close DoCmd.OutputTo acOutputReport, "Report1", acFormatPDF, exportPath, False MsgBox "تمت العملية بنجاح" & vbCrLf & _ IIf(response = vbYes, "تم حذف السجلات القديمة", "تم الاحتفاظ بالسجلات القديمة") & vbCrLf & _ "تم إضافة مسارات الصور الجديدة" & vbCrLf & _ "تم تصدير التقرير إلى: " & exportPath, _ vbInformation + vbMsgBoxRight, "" Else MsgBox "لم يتم اختيار أي ملفات", vbExclamation + vbMsgBoxRight, "" End If End With Set rs = Nothing: Set db = Nothing: Set fd = Nothing End Sub حيث يسمح لك الكود ، بحذف السجلات السابقة من الجدول أو الإحتفاظ بها وإضافة صور ( سجلات جديدة ) أو إلغاء العملية كاملة . ملف للتجربة :- frmPDF.zip

السلام عليكم طبعا وبادئ ذى بدئ اخى موسي فوق راسي وردى التالى ليس تقليلا او شئ من هذا القبيل اطلاقا ولكن فقط هذه وجهة نظرى قد اكون محطئ فيها وقد أصيب احل اخى موسي يبدو الطف فى الشكل الظاهرى ولكن ليس بالضرورة أخف تعتمد طريقة اخى موسى على انشاء سلسلة نصية و معالجة النص باستخدام (InStr وIIf) مما قد يكون بطئ نسبيا مع مرور الوقت وبالأخص مع وجود بيانات كبيرة بينما تعتمد طريقتى المتواضعة على استخدام شروط منطقية صريحة (AND - OR - NOT) والتى بدورها سوف تكون اسرع مع محرك الاستعلام لان التحقق يتم على القيم مباشرة دون تكوين سلاسل أو بحث نصي قاعدة ذهبيه مع الاستعلامات : دائما الأولوية للمنطق المباشر أفضل من الاعتماد على الحيل النصية

شكرا جزيلا أبي الفاضل وبارك الله فيك

لا أعلم طبيعة القاعدة التي تعمل عليها ، ولكن من خلال المرفقات التي يتم التنفيذ عليها ، هذه النتيجة :- فقط انا ما قمت به هو الملف المرفق من أستاذي أبو خليل ، وتنفيذ حدث "في الحالي" باستعمال الكود هذا ( مع تغيير اسم مربع النص ) :- Private Sub Form_Current() Dim strSQL As String If Not IsNull(Me.ID) Then strSQL = "SELECT COUNT(*) FROM (" & _ "SELECT modul.mouadel_3am FROM info_stagiere " & _ "LEFT JOIN modul ON info_stagiere.ID = modul.id " & _ "WHERE info_stagiere.annee='" & [Forms]![frm_examen_fin_formation]![annet] & "' " & _ "AND info_stagiere.grade='" & [Forms]![frm_examen_fin_formation]![grade1] & "' " & _ "AND info_stagiere.wilaya='" & [Forms]![frm_examen_fin_formation]![wilaya1] & "'" & _ ") WHERE mouadel_3am >= " & Me.mouadel_3am Me.txt_myoutonum = CurrentDb.OpenRecordset(strSQL)(0) End If End Sub وهذا الملف بعد التطبيق عليه الذي ارفقه معلمي ابو خليل سابقاً baseC4.zip

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

الف شكر لكم احبتي الحلول كلها تعطي نتيجة صحيحة ،، وحل الأخ موسى الطف وأخف نعم اطلعت عليه الآن يوجد وجه شبه .. ولكن الحلول هنا افضل في التعامل مع النتيجة اكرر شكري وامتناني ،،

الله يبارك فيك أخي الكريم .. شكراً على تهنئتكم اللطيفة

غفر الله لك ولوالديك .. شكراً على مرورك اللطيف

SELECT tblNames.UserId, tblNames.s_name, tblDays.day_id, tblDays.dayNm FROM tblDays, tblNames WHERE tblNames.UserId = [Forms]![Form1]![Combo0] AND ( (tblDays.day_id = 1 AND NOT tblNames.chekVuc1) OR (tblDays.day_id = 2 AND NOT tblNames.chekVuc2) OR (tblDays.day_id = 3 AND NOT tblNames.chekVuc3) OR (tblDays.day_id = 4 AND NOT tblNames.chekVuc4) OR (tblDays.day_id = 5 AND NOT tblNames.chekVuc5) OR (tblDays.day_id = 6 AND NOT tblNames.chekVuc6) OR (tblDays.day_id = 7 AND NOT tblNames.chekVuc7) ); اعتذر عندى مشكلة بالانترنت لا استطيع رفع مرفقات استاذى الجليل ومعلمى القدير و والدى الحبيب لا اعرف هل الافكار فى هذا الموضوع مشابهه ام تساعد فى تحقيق اى من اهدافكم الحالية او المستقبلية ام لا ولكن احسست بوجه شبه من بعيد او من قريب بينهم

وعليكم السلام 🙂 تفضل أستاذنا العود Database1_Moosa.accdb