Export .jpg vers PDF

Bonjour,

J'essaie de créer un macro sur excel vba qui me permettrai de transformer tout les fichiers .jpg d'un dossier en un PDF, puis de passer au prochain au dossier suivant, etc jusqu'à qu'il n'y ait plus de dossier. Voilà mon code :

Sub list()

Application.ScreenUpdating = False

    Const FPATH As String = "C:\Users\Lorian\Desktop\Example_jpegALL\"
    Dim d, coll As New Collection, file, f, folder, count As Integer, path2 As String

    coll.Add FPATH 'add the root folder
    'check for subfolders (one level only)
    d = Dir(FPATH, vbDirectory)
    Do While d <> ""
        If (GetAttr(FPATH & d) And vbDirectory) <> 0 Then
            If d <> "." And d <> ".." Then coll.Add FPATH & d
        End If
        d = Dir()
    Loop

    For Each folder In coll

        Sheet1.Activate
        path2 = FPATH & folder & "\"
        file = Dir(folder & "\*.jpg")
         Debug.Print folder
        Do While file <> ""
            Debug.Print , file

            count = ActiveSheet.Pictures.count
            'Insert picture into Excel
            With ActiveSheet.Pictures.Insert(path2 & file)
                .Left = count * 435
                .Top = ActiveSheet.Range("A1").Top
                .Width = 400
            End With

            ActiveSheet.Pictures(ActiveSheet.Pictures.count).Name = "A Picture"

            count = ActiveSheet.Pictures.count
            Debug.Print count
            file = Dir()
        Loop

        ChDir "C:\Users\Lorian\Desktop\Example_jpegALL\PDF"

        Debug.Print , folder

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="hey", _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False

        ActiveSheet.Pictures.Delete

        Sheet2.Activate

        Application.ScreenUpdating = True

    Next
End Sub

L'erreur vient du moment de l'importation, plus spécifiquement l'erreur 1004. Je trouve personnellement ce problème étrange, car le code marche pour un dossier (donc pour regrouper les fichier .jpg d'un seul dossier), mais ça ne marche plus quand j'essaie d'automatiser avec une boucle pour tous les autres dossiers. Voilà le code fonctionnel pour un dossier :

Sub JPG_PDF()
'
' JPG_PDF Macro
'
Application.ScreenUpdating = False

'Declare variables
Dim file
Dim path As String
Dim count As Integer

path = "C:\Users\Lorian\Desktop\Example_jpegALL\3\"
file = Dir(path & "*.jpg")

Debug.Print path
Sheet1.Activate

'Start loop
Do While file <> ""

Debug.Print file

count = ActiveSheet.Pictures.count
'Insert picture into Excel
With ActiveSheet.Pictures.Insert(path & file)
    .Left = count * 435
    .Top = ActiveSheet.Range("A1").Top
    .Width = 400
End With
ActiveSheet.Pictures(ActiveSheet.Pictures.count).Name = "A Picture"

count = ActiveSheet.Pictures.count
Debug.Print count

file = Dir()

Loop

ChDir "C:\Users\Lorian\Desktop\Example_jpegALL\PDF"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="file", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

ActiveSheet.Pictures.Delete

Sheet2.Activate

Application.ScreenUpdating = True

End Sub

Dernière précision, je suis sûr que les boucles marchent dans le premier code, car j'ai créer un code qui me donne comme output le nom de tous les fichiers .jpg qu'il y a dans tous les dossiers. je n'arrive juste pas à combiner les deux codes... :( merci à quiconque aurait une réponse ou une piste à me donner (je précise que je suis débutant sur excel vba).

Sur ce, bonne journée.

J'ai finalement trouvé la réponse, si ça interesse qqn, qu'il se manifeste !

Bonjour Lorian,

Il est de bon ton de mettre la solution même trouvée par soi même quand on posé une question
Pensez aux internautes qui passeront par ici en cherchant la même chose.

Cordialement.

Hop voilà le code :) le code passe dans tous les dossiers et compile toute sortes d'images (jpg, png) en pdf. Maximum 100 dossiers, après ça crash en général. Autre précision, il ne faut AUCUN accent sinon le code ne marche pas...

Pour adapter le code, il faut changer la const FPATH et changer le ChDir, et sinon tout devrait jouer.

Sub JPG_TO_PDF()

Application.ScreenUpdating = False

    Const FPATH As String = "G:\qgis\Folder_input\"
    Dim d, coll As New Collection, file, f, folder, count As Integer, path2 As String, flag As Boolean, name As String, num As Integer

    coll.Add FPATH 'add the root folder
    'check for subfolders (one level only)
    d = Dir(FPATH, vbDirectory)
    Do While d <> ""
        If (GetAttr(FPATH & d) And vbDirectory) <> 0 Then
            If d <> "." And d <> ".." Then coll.Add FPATH & d
        End If
        d = Dir()
    Loop

    flag = False

    For Each folder In coll

        Sheet1.Activate
        path2 = folder & "\"
        file = Dir(folder & "\*.jpg")
        num = Len(folder) - Len(Replace(folder, "\", ""))
        name = Replace(folder, "\", "", , num - 1)
        name = Right(name, Len(name) - InStr(name, "\") + 1)
        name = Replace(name, "\", "", , 1)

        If flag = True Then

        Do While file <> ""

            count = ActiveSheet.Pictures.count
            'Insert picture into Excel
            With ActiveSheet.Pictures.Insert(path2 & file)
                .Left = count * 435
                .Top = 50
                .Width = 400
            End With

            ActiveSheet.Pictures(ActiveSheet.Pictures.count).name = "A Picture"
             ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                80 + count * 435, 0, 250, 25) _
                 .TextFrame.Characters.Text = file
            file = Dir()
        Loop

        ChDir "G:\qgis\PDF\Output\"

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=name, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False

        Debug.Print name; " !! PRINTED !!"

        ActiveSheet.Pictures.Delete
        ActiveSheet.TextBoxes.Delete

        Sheet2.Activate

        Application.ScreenUpdating = True

        End If

        flag = True

    Next
End Sub