[XL-2016] pdftopng avec Excel 2016

Tout d'abord merci kiki29 pour ce superbe travail sur PDF et Excel

Je repose ici ma question car je n'ai vu que trop tard qu'il ne fallait pas le faire sur le post d'origine.

Je suis sous Excel 2016

J'ai utilisé le code ci-dessous in extenso (en ajoutant PtrSafe pour 64bit au début) en mettant tous les fichiers au bon endroit (il me semble) mais, bien que les dossiers soient bien créés, aucun PNG n'est généré.

@kiki29, serait-il possible d'avoir de l'aide ?

Merci d'avance.

Citation:

Envoyé par kiki29

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:

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