دمج مجموعة صور في ملف Pdf

[العنزي العنزي]

السلام عليكم اصدقائي الغالين ورحمة الله وبركاته 

طلبي هو دمج مجموعة صور في ملف Pdf بحيث عندي مجلد اسمه A1 فيه مجموعة صور اريد دمجها في ملف Pdf وخزنها في مجلد ثاني اسمه A2 وهذا برنامج عينة بسيط 

لغرض العمل عليه 

مع فائق الشكر والتقدير لكم جميعا 

 

frmPDF.rar

تم تعديل منذ 11 ساعات بواسطه ابوخليل
تم استبدال المرفق الى المرفق الصحيح

[Foksh]

وعليكم السلام ورحمة الله وبركاته 🤗..

كفكرة ، قم بإنشاء تقرير يجلب الصور من مساراتها ، ثم قم بتصدير التقرير إلى ملف PDF .

أعتقد هذا أنسب حل لك 😉 .

أتابع من الجوال 

[العنزي العنزي]

السلام عليكم استاذي الفاضل Foksh ورحمة الله وبركاته 

جزاك الله خيرا وشكرا جزيلا لحضرتك يا طيب ممنون من حضرتك 

استاذي الفاضل ممكن ان تجعل كل صورة في صفحة ليكون ملف ال Pdf فيه كل الصور  

مع وافر التحايا 

[ابوخليل]

13 ساعات مضت, Foksh said:

وعليكم السلام ورحمة الله وبركاته 🤗..

كفكرة ، قم بإنشاء تقرير يجلب الصور من مساراتها ، ثم قم بتصدير التقرير إلى ملف PDF .

أعتقد هذا أنسب حل لك 😉 .

أتابع من الجوال 

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

[Foksh]

5 ساعات مضت, العنزي العنزي said:

السلام عليكم استاذي الفاضل Foksh ورحمة الله وبركاته 

جزاك الله خيرا وشكرا جزيلا لحضرتك يا طيب ممنون من حضرتك 

استاذي الفاضل ممكن ان تجعل كل صورة في صفحة ليكون ملف ال Pdf فيه كل الصور  

مع وافر التحايا 

تفضل أخي الكريم ، ما تم هو:-

انشاء جدول يحتوي حقل ترقيم تلقائي ( ليس ذا علاقة بالموضوع ، ولكنه عادة ... ) ، وحقل لإضافة المسارات اليه عند اختيارك للصور .

ثم إنشاء تقرير مصدره الجدول السابق ، وتم إنشاء عنصر صورة مصدره المربع النصي المرتبط بالحقل الخاص بالمسارات .

ثم داخل التقرير لعرض كل صورة في صفحة مستقلة ، في قسم التفاصيل =  = تقسيم الصفحات بعد هذا الجزء .

وفي نموذج الإفتراضي ، في الزر جعلت لك الأحداث داخل نفس الزر بحيث عند النقر عليه ، تستطيع اختيار الصور التي تريدها ، وبعد الموافقة عليها سيتم فتح التقرير وتصديره الى ملف 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

[Foksh]

4 ساعات مضت, ابوخليل said:

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

تمازحني بلا شك معلمي الفاضل 😅 ..

هذه محاولة قديمة تتعامل مع الأمر نفسه بدون جدول أو تقرير من خلال Word . ولكني لم أدرجها خشية أن يقول لي أحد أنه ماذا لو لم يكن هناك برنامج Word  .

 

    Dim fd As Object
    Dim selectedFile As Variant
    Dim pdfPath As String
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim imgPath As String
    Dim imgCount As Integer
    Dim firstImage As Boolean
    
    Set fd = Application.FileDialog(3)
    With fd
        .Title = "اختر الصور المطلوبة"
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "ملفات الصور", "*.jpg;*.jpeg;*.png;*.bmp;*.gif"
        
        If .Show = -1 Then
            pdfPath = CurrentProject.Path & "\A2\الصور_المحددة_" & Format(Now(), "yyyy-mm-dd_hh-mm-ss") & ".pdf"
            
            If Dir(CurrentProject.Path & "\A2", vbDirectory) = "" Then
                MkDir CurrentProject.Path & "\A2"
            End If
            
            Set wordApp = CreateObject("Word.Application")
            Set wordDoc = wordApp.Documents.Add
            wordApp.Visible = False
            
            With wordDoc.PageSetup
                .Orientation = 0
                .TopMargin = 36
                .BottomMargin = 36
                .LeftMargin = 36
                .RightMargin = 36
            End With
            
            imgCount = 0
            firstImage = True
            
            For Each selectedFile In .SelectedItems
                imgPath = CStr(selectedFile)
                imgCount = imgCount + 1
                
                With wordDoc.Content
                    If Not firstImage Then
                        .InsertBreak 2 ' فاصل صفحة قبل الصورة الجديدة (ماعدا الأولى)
                    Else
                        firstImage = False
                    End If
                    
                    .InsertAfter vbCrLf
                    .ParagraphFormat.Alignment = 1
                    .InlineShapes.AddPicture imgPath, False, True
                End With
                
                With wordDoc.InlineShapes(wordDoc.InlineShapes.Count)
                    .LockAspectRatio = True
                    If .Width > 500 Then .Width = 500
                End With
            Next selectedFile
            
            wordDoc.Range(0, 0).Delete
            
            wordDoc.SaveAs2 pdfPath, 17
            wordDoc.Close False
            wordApp.Quit
            
            MsgBox "بنجاح إلى المسار PDF تم تصدير الصور لملف " & vbCrLf & _
                   pdfPath, _
                   vbInformation + vbMsgBoxRight, ""
        Else
            MsgBox "لم يتم اختيار أي صور", vbExclamation + vbMsgBoxRight, ""
        End If
    End With
    
    Set wordDoc = Nothing
    Set wordApp = Nothing
    Set fd = Nothing

وتم توضيح بعض الأجزاء بتعليقات بسيطة ..

 

[العنزي العنزي]

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

[ابو جودي]

انا عجبتنى الافكار بس اضفت بعض البهارات للطبخة 

اتمنى لكم مذاقا هنيئا 

 

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 جزاه الله خيرا وشكرا جزيلا للاستاذ الفاضل ابو خليل جزاه الله خيرا وشكرا جزيلا للستاذ الفاضل  ابو جودي جزاه الله خيرا ... اساتذتي الافاضل طلبي هو لا اريد اختيار الذي اريده هو ألي بضغطة زر يحول لي الصور وتظهر في التقرير بدون روابط

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

جزاكم الله خيرا وربي يحفظكم جميعا يارب وهذا المشروع في المرفقات

Arshafah.rar

تم تعديل منذ 1 ساعه بواسطه العنزي العنزي

[Foksh]

25 دقائق مضت, العنزي العنزي said:

طلبي هو لا اريد اختيار الذي اريده هو ألي بضغطة زر يحول لي الصور وتظهر في التقرير بدون روابط

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

جزاكم الله خيرا وربي يحفظكم جميعا يارب وهذا المشروع في المرفقات

يعني باختصار لما تفضلت به أعلاه :-

تريد ان يتم دمج الصور التي في المجلد A1 بغض النظر عن عددها أو طبيعتها أو تكراراتها ، في ملف PDF داخل المجلد A2 !!!!!؟

وإذا كان غير صحيح ما فهمته ، ارجو منك التوضيح بشكل أكثر دقة . وتحديد وظيفة الجدول tblAttach ؟؟؟؟؟

[العنزي العنزي]

حياك الله استاذي الفاضل Foksh ربي يخليك يارب نعم اريد ان يتغير الرابط بدلا من المجلد A1 يتغير الى مجلد ال PDF وملف ال PDF المدمج 

يعني دمجها في ملف PDF في مجلد PDF وتغير الرابط في الجدول حسب الحفظ الاخير ثم حذف الصور من المجلد A1

[Foksh]

طيب تمام ، الآن اللي وضح لي كالآتي :-

1. من خلال الزر ، تريد ان يتم دمج الصورة الى المجلد PDF بملف بصيغة PDF بحيث كل صورة في صفحة .

2. بعد التصدير ونجاح العملية ، حذف الصور وتفريغ المجلد A1 من محتوياته .

 

لكن الغير واضح هو :-

20 دقائق مضت, العنزي العنزي said:

تغير الرابط في الجدول حسب الحفظ الاخير ثم حذف الصور من المجلد A1

أرجو منك التوضيح بشكل يسير أخي الفاضل !!

[العنزي العنزي]

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

وهنا ان الصور بلا روابط فقط رابط المجلد الذي يحتويها في الاخير انا اريد تحويل الصور ودمجه في ملف ةاحد pdf سواءا عبر التقرير او غيره 

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

[Foksh]

3 دقائق مضت, العنزي العنزي said:

اريد تحويل الصور ودمجه في ملف ةاحد pdf سواءا عبر التقرير او غيره

طيب ، جرب هذا الحل الذي لا يعتمد على اي تقرير أو جدول , حيث سيتم قراءة الصور من المجلد A1 ، ثم دمجها إلى ملف PDF داخل المجلد PDF .

لم أضف فكرة حذف الصور بعد الدمج حتى تتأكد من أن هذا طلبك 100%

 

 

Arshafah.zip

[العنزي العنزي]

استاذي الفاضل Foksh كلمة شكرا قليلة في حقك ممنون من حضرتك يا طيب نسأل الله جل شأنه ان يمن عليك بالصحة والعافية والخير والبركات تمام 100 % ما نستغنى عن حضرتك يا طيب 

[Foksh]

ولا يهمك أخي الفاضل .. استكمل باقي المطلوب بشكل واضح ، وإن شاء الله تجد مطلبك ..