Bonjour,

J'ai réutilisé votre code in extenso (en ajoutant PtrSafe pour 64bit) : les répertoire sont bien créés mais aucun PNG n'est généré.

SI vous suivez encore ces posts, pouvez-vous m'aider svp ? (je suis sous Excel 2016)

Merci d'avance


Citation Envoyé par kiki29 Voir le message
Placer l'utilitaire pdftopng.exe ( renommé ici en pdftopng32.exe ) dans le dossier de l'appli.
Cet utilitaire est dans xpdfbin-win-3.04.zip

Le pdf sélectionné sera converti dans un dossier par défaut : ici nommé "PNG"
Ce dossier est créé, s'il n'existe pas à la racine de l'appli, les doublons éventuels sont gérés.

Appli en téléchargement ici

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub PDF2Png(ByVal sFichier)
Dim Wsh As Object, sCheminAppli As String, sDossierRacine As String
Dim sNomFichierPS As String, sPre As String, FSO As Object, sNomImages As String
Dim sDossierImages As String, bVide As Boolean
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sPre = FSO.GetBaseName(sFichier)
    Set FSO = Nothing
 
    sCheminAppli = ThisWorkbook.Path & "\" & "pdftopng32.exe"
    sDossierRacine = ThisWorkbook.Path & "\" & "PNG"
 
    CreationDossier sDossierRacine
 
    sDossierImages = RenommerDossier(sDossierRacine, sPre)
    sNomImages = sDossierImages & "\" & sPre
 
    Set Wsh = CreateObject("WScript.Shell")
 
    Wsh.Run "cmd  /c  chcp 65001 && " & Chr(34) & sCheminAppli & Chr(34) & Chr(32) _
            & Chr(34) & sFichier & Chr(34) & " -aa yes -r 72 -aaVector yes " _
            & Chr(34) & sNomImages, vbHide, True
    Set Wsh = Nothing
End Sub
 
Private Function RenommerDossier(ByVal sChemin As String, ByVal sDossier As String) As String
Dim sNouveauNom As String, sNomDossier As String
Dim i As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(sChemin & "\" & sDossier) Then
        sNouveauNom = sDossier
        i = 0
        While FSO.FolderExists(sChemin & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sDossier & Chr(40) & Format(i, "000") & Chr(41)
        Wend
        sNomDossier = sNouveauNom
    Else
        sNomDossier = sDossier
    End If
    Set FSO = Nothing
 
    CreationDossier sChemin & "\" & sNomDossier
    RenommerDossier = sChemin & "\" & sNomDossier
End Function