IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Contribuez Discussion :

Excel / Word / PDF avec Adobe Acrobat Pro et PDFCreator 1.7.3 (obsolète)


Sujet :

Contribuez

  1. #81
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    Salut, Acrobat Reader en est à la version 11.0.06 et il est gratuit.
      2  0

  2. #82
    Membre expert
    Avatar de sachadee
    Homme Profil pro
    AMI DU BAT
    Inscrit en
    janvier 2013
    Messages
    1 478
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Brésil

    Informations professionnelles :
    Activité : AMI DU BAT
    Secteur : Distribution

    Informations forums :
    Inscription : janvier 2013
    Messages : 1 478
    Points : 3 768
    Points
    3 768
    Par défaut
    Salut et merci,

    Je viens de tester avec la dernière version de acrobat reader et même problème :

    Voici le message d'erreur :

    Nom : Messerreur1.JPG
Affichages : 8613
Taille : 25,4 Ko
    ________________________________
    Un p'tit coup de pouce ça fait toujours plaisir, pensez-y !
    ________________________________
      0  0

  3. #83
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    re, encore une police fantaisiste(?) et donc il n'y aurait pas à s'étonner. Par curiosité pourrais-tu poster ce fichier pdf, s'il ne contient rien de confidentiel ?

    qqs pistes :
    voir aussi ici
    celà provient peut-être du logiciel qui a servi à créer le pdf, l'option incorporer les polices n'a pas du être cochée ?

    Dans les options du reader Edition/préférences/affichage le rendu doit être coché en utilisant les polices locales.
      2  0

  4. #84
    Membre expert
    Avatar de sachadee
    Homme Profil pro
    AMI DU BAT
    Inscrit en
    janvier 2013
    Messages
    1 478
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Brésil

    Informations professionnelles :
    Activité : AMI DU BAT
    Secteur : Distribution

    Informations forums :
    Inscription : janvier 2013
    Messages : 1 478
    Points : 3 768
    Points
    3 768
    Par défaut
    Je viens de faire un test avec d'autre pdf et ça marche c'est seulement ce pdf qui pose problème. Etonnement !
    Et c'est avec ce fichier que je faisais mes tests (J'ai perdu au moins 3 heures à cause de ça....)

    Donc on va laisser ça comme ça jusqu'à ce que j'arrive à reproduire l'erreur et là on n'en reparlera.

    En tous cas merci pour ton aide.

    ________________________________
    Un p'tit coup de pouce ça fait toujours plaisir, pensez-y !
    ________________________________
      1  0

  5. #85
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    PDFCreator Modifier l'ordre dans la queue d'impression puis fusionner le tout en un seul PDF
    Adapté d'un vbs fourni avec l'installation

    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
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    Option Explicit
     
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
     
    Private Sub CreateTextfileAndPrint(sFichier As String, sContenu As String)
    Dim FSO As Object, F As Object
    Dim PDFCreator2 As Object
     
        Set PDFCreator2 = CreateObject("PDFCreator.clsPDFCreator")
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set F = FSO.CreateTextFile(sFichier, True)
     
        F.WriteLine (sContenu)
        F.Close
        PDFCreator2.cPrintfile (sFichier)
     
        Sleep 2000
        FSO.DeleteFile (sFichier)
     
        Set F = Nothing
        Set FSO = Nothing
        Set PDFCreator2 = Nothing
    End Sub
     
    Sub CombinaisonJobs()
    Dim PDFCreator As Object
    Dim sDefaultPrinter As String, c As Long, sOut As String
    Dim FSO As Object, sDossierOut As String
    Const maxTime = 30    ' s
    Const sleepTime = 250    ' ms
    Const sNomFichier = "Ordre impression"
     
        Set PDFCreator = CreateObject("PDFCreator.clsPDFCreator")
        Set FSO = CreateObject("Scripting.FileSystemObject")
     
        sDossierOut = ThisWorkbook.Path & "\" & "Resultats PDF" & "\"
        If Not FSO.FolderExists(sDossierOut) Then FSO.CreateFolder (sDossierOut)
        Set FSO = Nothing
     
        PDFCreator.cStart "/NoProcessingAtStartup"
        With PDFCreator
            .cPrinterStop = True
            .cOption("UseAutosave") = 1
            .cOption("UseAutosaveDirectory") = 1
            .cOption("AutosaveDirectory") = sDossierOut
            .cOption("AutosaveFilename") = sNomFichier
            sDefaultPrinter = .cDefaultprinter
            .cDefaultprinter = "PDFCreator"
            .cClearcache
     
            ' 1. page
            CreateTextfileAndPrint sDossierOut & "1.txt", "1"
            ' 2. page
            CreateTextfileAndPrint sDossierOut & "2.txt", "2"
            ' 3. page
            CreateTextfileAndPrint sDossierOut & "3.txt", "3"
            ' 4. page
            CreateTextfileAndPrint sDossierOut & "4.txt", "4"
     
            ' Attendre que tout soit dans la queue d'impression
            Sleep 2000
     
            ' Ordre des pages : 1 2 3 4
     
            .cMovePrintjobTop 3
            ' Ordre des pages : 3 1 2 4
     
            .cMovePrintjobBottom 2
            ' Ordre des pages : 3 2 4 1
     
            .cMovePrintjobDown 2
            ' Ordre des pages : 3 4 2 1
     
            .cMovePrintjobUp 2
            ' Ordre des pages : 4 3 2 1
     
            .cDeletePrintjob 1
            ' Ordre des pages : 3 2 1
     
            ' On fusionne le tout dans un seul pdf 
            .cCombineAll
     
            ' On démarre l'imprimante
            .cPrinterStop = False
     
            c = 0
            Do While (.cOutputFilename = "") And (c < (maxTime * 1000 / sleepTime))
                c = c + 1
                Sleep sleepTime
            Loop
            sOut = .cOutputFilename
        End With
     
        With PDFCreator
            .cDefaultprinter = sDefaultPrinter
            Sleep 200
            .cClose
        End With
     
        Set PDFCreator = Nothing
     
        If sOut = "" Then
            MsgBox "Création du fichier PDF." & vbCrLf & vbCrLf & _
                    "Une erreur s'est produite : temps écoulé !", vbExclamation + vbSystemModal
        End If
    End Sub
      2  0

  6. #86
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    Acrobat Extraction de pages d'un catalogue PDF et insertion de ces PDF en réduction sur une feuille Excel
    Dans un classeur Excel
    Créer sur une feuille en A2...Axy la liste des pages à extraire.
    En B2 : une plage nommée NbPagesH qui détermine le nombre de PDF disposés horizontalement.
    Affecter un bouton à la procédure SelFichier.

    Dans ce code ShParam est le CodeName de la feuille : voir pour explications CodeName
    Il en est de même pour ShRecap.

    pour PDFCreator voir Post# 25

    Dans un module standard insérer le code suivant :
    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
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
    Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
     
    Option Explicit
     
    Dim Dep As Currency, Fin As Currency, Freq As Currency
    Dim sOut As String
    Dim bFlag As Boolean
     
    Private Sub DeleteAllSheets()
    Dim Ws As Worksheet
        For Each Ws In ThisWorkbook.Worksheets
            If Ws.Name <> ShParam.Name And Ws.Name <> ShRecap.Name Then
                Application.DisplayAlerts = False
                Ws.Delete
                Application.DisplayAlerts = True
            End If
        Next Ws
    End Sub
     
    Sub DelOleRecapIns()
    Dim oOle As OLEObject
        For Each oOle In Worksheets(ShRecap.Name).OLEObjects
            ShRecap.Shapes(oOle.Name).Delete
        Next oOle
    End Sub
     
    Private Sub ExtractionPDF(sNom As String, iNumPage As Long)
    Dim PDDocSource As Object
    Dim iNbPages As Long
     
        Set PDDocSource = CreateObject("AcroExch.PDDoc")
        PDDocSource.Open sNom
     
        iNbPages = PDDocSource.GetNumPages
        PDDocSource.Close
     
        If iNumPage > iNbPages Then
            bFlag = True
            Set PDDocSource = Nothing
            Exit Sub
        End If
     
        Split_Fichier sNom, iNumPage
     
        Set PDDocSource = Nothing
    End Sub
     
    Private Sub InsertionPDF(ByVal sNomFichier As String)
    Dim LastRow As Long, i As Long
     
        ShParam.Range("A2:A" & Rows.Count).Interior.ColorIndex = xlNone
     
        DeleteAllSheets
        DelOleRecapIns
     
        Application.ScreenUpdating = False
        LastRow = ShParam.Range("A" & Rows.Count).End(xlUp).Row
     
        sOut = ThisWorkbook.Path & "\" & "Extraction.pdf"
        bFlag = False
        For i = 2 To LastRow
            ExtractionPDF sNomFichier, ShParam.Range("A" & i)
            If bFlag Then
                ShParam.Range("A" & i).Interior.ColorIndex = 36
                Exit For
            End If
     
            With ShRecap
                .Activate
                .Range("A1").Select
                .OLEObjects.Add Filename:=sOut
            End With
            Application.StatusBar = "Insertion : " & i - 1 & " / " & LastRow - 1
        Next i
     
        ShParam.Activate
        Kill sOut
        Application.ScreenUpdating = True
    End Sub
     
    Sub PosShapesIns()
    Dim oOle As OLEObject
    Dim i As Long
    Dim L As Double, W As Double
    Dim T As Double, H As Double, Pas As Double, PasDepart As Double
    Dim Tablo() As String, sNomOle As String
    Dim Nb As Long, Coeff As Double
     
        i = 0
        For Each oOle In Worksheets(ShRecap.Name).OLEObjects
            sNomOle = ShRecap.Shapes(oOle.Name).Name
            ReDim Preserve Tablo(i)
            Tablo(i) = sNomOle
            i = i + 1
        Next oOle
     
        If i = 0 Then Exit Sub
     
        With ShRecap.Shapes(Tablo(0))
            W = .Width
            H = .Height
            Coeff = H / W
        End With
     
        W = Application.CentimetersToPoints(6)
        H = W * Coeff
        Pas = Application.CentimetersToPoints(0.25)
        PasDepart = Application.CentimetersToPoints(0.25)
     
        Nb = ShParam.Range("NbPagesH")
        For i = LBound(Tablo) To UBound(Tablo)
            L = PasDepart + (i Mod Nb) * (W + Pas)
            T = PasDepart + (i \ Nb) * (H + Pas)
            With ShRecap.Shapes(Tablo(i))
                .Left = L
                .Top = T
                .Width = W
                .Height = H
            End With
        Next i
     
        With ShRecap
            .Activate
            .Range("A1").Select
        End With
    End Sub
     
    Sub SelFichier()
    Dim Fichier As Variant
    Dim s As Double
        ChDir ThisWorkbook.Path & "\"
        Fichier = Application.GetOpenFilename("Fichiers PDF (*.pdf), *.pdf", Title:="Sélection PDF pour Insertion Excel")
        If Fichier = False Then Exit Sub
        DoEvents
        QueryPerformanceCounter Dep
        Application.StatusBar = ""
     
        InsertionPDF Fichier
        PosShapesIns
     
        QueryPerformanceCounter Fin
        QueryPerformanceFrequency Freq
        s = (Fin - Dep) / Freq
        Application.StatusBar = Application.StatusBar & " : " & Format(s, "0.00 s")
    End Sub
     
    Private Sub Split_Fichier(sNomFichier As String, iNb As Long)
    Dim PDDocSource As Object   
    Dim PDDocDestination As Object    
    Dim sNomPdf As String
     
        Set PDDocSource = CreateObject("AcroExch.PDDoc")
        PDDocSource.Open sNomFichier
     
        Set PDDocDestination = CreateObject("AcroExch.PDDoc")
        PDDocDestination.Create
        sNomPdf = sOut
     
        'nInsertPageAfter
        '   La page du document Destination après laquelle les pages du document Source seront insérées.
        '   La 1ere page d'un document est la page 0.
        'iPDDocSource
        '   Le document Source contenant les pages à insérer.
        'nStartPage
        '   La 1ere page a être insérée dans le document Destination.
        'nNumPages
        '   Le nombre de pages à insérer.
        'bBookmarks
        '   Si le nombre est positif alors les signets du document Source sont copiés.
        '   Si 0, alors non.
     
        With PDDocDestination
            .InsertPages -1, PDDocSource, iNb - 1, 1, 0
            .Save 1, sNomPdf
            .Close
        End With
     
        Set PDDocDestination = Nothing
        Set PDDocSource = Nothing
    End Sub
      2  0

  7. #87
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    PDFCreator Affichage du log d'activité de PDFCreator
    Adapté d'un vbs fourni avec l'installation

    Ce log est généré si dans le menu Imprimante de PDFCreator.exe l'option Journal est cochée

    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
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    Option Explicit
     
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    Private Const SW_SHOWNORMAL = 1
    Private Const HTMLFile = "PDFCreator_logfile.htm"
     
    Private Sub CreateHTMLFile(sFilename As String, Content As String)
    Dim F As Object, FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set F = FSO.CreateTextFile(sFilename, True)
            F.Write Content
            F.Close
        Set F = Nothing
        Set FSO = Nothing
    End Sub
     
    Private Function Footer()
        Footer = "</body>" & vbCrLf & "</html>"
    End Function
     
    Private Function Header()
    Dim sStr As String, sTitle As String, pdfcreator As Object
        Set pdfcreator = CreateObject("PDFCreator.clsPDFCreator")
        sTitle = "PDFCreator logfile"
        sStr = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01//EN"""
        sStr = sStr & vbCrLf & "<html>"
        sStr = sStr & vbCrLf & "<head>"
        sStr = sStr & vbCrLf & "<title>" & sTitle & "</title>"
        sStr = sStr & vbCrLf & "</head>"
        sStr = sStr & vbCrLf & "<body>"
        sStr = sStr & vbCrLf & "<h1>" & sTitle & "</h1>"
        sStr = sStr & vbCrLf & "<p>Windows version : " & pdfcreator.cWindowsversion & "</p>"
        sStr = sStr & vbCrLf & "<p>Program release : " & pdfcreator.cProgramRelease & "</p>"
        sStr = sStr & vbCrLf & "<p>Chemin application : " & pdfcreator.cPDFCreatorApplicationPath & "</p>"
        sStr = sStr & vbCrLf & "<p>Version Ghostscript : " & pdfcreator.cGhostscriptVersion & "</p>"
        sStr = sStr & vbCrLf & "<p>Imprimante par défaut : " & pdfcreator.cDefaultPrinter & "</p>"
     
        If pdfcreator.cInstalledAsServer Then
            sStr = sStr & vbCrLf & "<p>Installation mode : Server</p>"
        Else
            sStr = sStr & vbCrLf & "<p>Installation mode : Standard</p>"
        End If
        If pdfcreator.cOption("Logging") = 1 Then
            sStr = sStr & vbCrLf & "<p>Logging : Activé</p>"
        Else
            sStr = sStr & vbCrLf & "<p>Logging : Désactivé</p>"
        End If
        Header = sStr & vbCrLf & "<p>--------------------------------</p>" & vbCrLf
        Set pdfcreator = Nothing
    End Function
     
    Sub Log()
    Dim pdfcreator As Object, ProgramIsRunning As Boolean
    Dim hwnd As Long
     
        Set pdfcreator = CreateObject("PDFCreator.clsPDFCreator")
     
        ProgramIsRunning = pdfcreator.cProgramIsRunning
        pdfcreator.cVisible = False
        pdfcreator.cStart "/NoProcessingAtStartup", True
     
        CreateHTMLFile HTMLFile, Header & LogFile & Footer
     
        If ProgramIsRunning = False Then
            'Sleep 200
            pdfcreator.cClose
        End If
        Set pdfcreator = Nothing
     
        ShellExecute hwnd, "Open", HTMLFile, 0&, 0&, SW_SHOWNORMAL
    End Sub
     
    Private Function LogFile()
    Dim pdfcreator As Object
        Set pdfcreator = CreateObject("PDFCreator.clsPDFCreator")
        LogFile = Replace(ReplaceForbiddenChars(CStr(pdfcreator.cGetLogfile)), vbCrLf, "<br>") & vbCrLf
        Set pdfcreator = Nothing
    End Function
     
    Private Function ReplaceForbiddenChars(value)
    Dim sStr As String
        sStr = Replace(value, "&", "&amp;")
        sStr = Replace(sStr, "<", "&lt;")
        sStr = Replace(sStr, ">", "&gt;")
        sStr = Replace(sStr, """", "&quot;")
        ReplaceForbiddenChars = sStr
    End Function
      2  0

  8. #88
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    PDFCreator Fusion des fichiers PDF d'un dossier avec recherche récursive ou non de ces fichiers

    Le code de recherche des fichiers ( ici *.pdf ) utilise les APIs.

    Créer 3 boutons et une case à cocher sur la feuille 1.
    ● Le 1er baptisé btnListe avec intitulé "Liste Fichiers PDF" sera affecté à la procédure Usf du module mRch.
    ● Le 2eme baptisé btnFusion avec intitulé "Fusion Liste Fichiers PDF" sera affecté à la procédure FusionPdf du module mFusion.
    ● Le 3eme baptisé btnEffacer avec intitulé "Effacer" sera affecté à la procédure Effacer du module mRch.
    ● La case à cocher avec intitulé "Recherche Récursive ?" baptisée chkRecur.

    Créer une UserForm avec 2 boutons et une TextBox
    ● Le 1er bouton avec intitulé "Sélection Dossier Racine" sera affecté à la procédure CommandButton1_Click du code de l'UserForm.
    ● Le 2eme bouton avec intitulé "Annuler" sera affecté à la procédure CommandButton2_Click du code de l'UserForm.
    ● La TextBox avec sa propriété value = *.pdf sera baptisée txtBox

    Dans ces codes ShDatas est le CodeName de la feuille 1 : voir pour explications CodeName.

    Code de l'UserForm
    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
    Option Explicit
     
    Private Sub CommandButton1_Click()
        sRch = txtBox.Text
        If Len(sRch) = 0 Then
            Me.Hide
            Exit Sub
        End If
        Me.Hide
        SelDossierRacine
    End Sub
     
    Private Sub CommandButton2_Click()
        Me.Hide
        ShDatas.Range("B2").Select
    End Sub
     
    Private Sub UserForm_Initialize()
        If Len(ShDatas.Range("A2")) = 0 Then ShDatas.Range("A2") = "*.pdf"
        txtBox.Text = ShDatas.Range("A2")
    End Sub
    dans module standard baptisé mRch
    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
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    Option Explicit
     
    Private Const vbDot = 46
    Private Const MAX_PATH As Long = 260
    Private Const INVALID_HANDLE_VALUE = -1
    Private Const vbBackSlash = "\"
    Private Const ALL_FILES = "*.*"
     
    Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
    End Type
     
    Private Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * MAX_PATH
        cAlternate As String * 14
    End Type
     
    Private Type FILE_PARAMS
        bRecurse As Boolean
        bFindOrExclude As Long
        nCount As Long
        nSearched As Long
        sFileNameExt As String
        sFileRoot As String
    End Type
     
    Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
    Private Declare Function FindFirstFile Lib "kernel32" _
            Alias "FindFirstFileA" _
            (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function FindNextFile Lib "kernel32" _
            Alias "FindNextFileA" _
            (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
    Private Declare Function PathMatchSpec Lib "shlwapi" _
            Alias "PathMatchSpecW" _
            (ByVal pszFileParam As Long, ByVal pszSpec As Long) As Long
     
    Private FP As FILE_PARAMS
    Private iNbDossiers As Long
     
    Sub Effacer()
        With ShDatas
            .Activate
            .Columns("B:B").ClearContents
            .Range("A1").ClearContents
            .Range("A3:A5").ClearContents
            PosBoutons
            .Range("B2").Select
        End With
    End Sub
     
    Private Function MatchSpec(sFile As String, sSpec As String) As Boolean
        MatchSpec = PathMatchSpec(StrPtr(sFile), StrPtr(sSpec)) = FP.bFindOrExclude
    End Function
     
    Private Function QualifyPath(sPath As String) As String
        If Right$(sPath, 1) <> vbBackSlash Then
            QualifyPath = sPath & vbBackSlash
        Else
            QualifyPath = sPath
        End If
    End Function
     
    Private Sub Rch(sRacine As String)
    Dim Debut As Currency, Fin As Currency, Freq As Currency
     
        With ShDatas
            .Columns("A:B").ClearContents
            .Cells(1, 1) = sRacine
            .Cells(2, 1) = sRch
            .Cells(3, 1) = ""
            .Cells(4, 1) = ""
            .Cells(5, 1) = ""
            .Range("B:B").Clear
        End With
     
        ActiveWindow.ScrollRow = 1
        ActiveWindow.ScrollColumn = 1
     
        Application.ScreenUpdating = False
        With FP
            .sFileRoot = QualifyPath(ShDatas.Cells(1, 1))
            .sFileNameExt = ShDatas.Cells(2, 1)
            .bRecurse = ShDatas.CheckBoxes("chkRecur").Value = 1
            .nCount = 0
            .nSearched = 0
            iNbDossiers = 0
            '   0=inclus tous les fichiers
            '   1=exclus sauf extension : ici pdf
            .bFindOrExclude = 1
        End With
     
        QueryPerformanceCounter Debut
        SearchForFiles FP.sFileRoot
        QueryPerformanceCounter Fin
        QueryPerformanceFrequency Freq
     
        With ShDatas
            '.Cells(3, 1) = Format$(FP.nSearched, "###,###,###,##0")
            .Cells(3, 1) = iNbDossiers & " Dossiers"
            .Cells(4, 1) = Format$(FP.nCount, "###,###,###,##0 Fichiers")
            .Cells(5, 1) = FormatNumber((Fin - Debut) / Freq, 3) & " s"
     
            .Range("A1:A5").HorizontalAlignment = xlLeft
            .Range("A2:A5").Columns.AutoFit
            PosBoutons
        End With
     
        Application.ScreenUpdating = True
    End Sub
     
    Private Sub SearchForFiles(sRoot As String)
    Dim WFD As WIN32_FIND_DATA
    Dim hFile As Long
        hFile = FindFirstFile(sRoot & ALL_FILES, WFD)
        If hFile <> INVALID_HANDLE_VALUE Then
            Do
                If (WFD.dwFileAttributes And vbDirectory) Then
                    If Asc(WFD.cFileName) <> vbDot Then
                        iNbDossiers = iNbDossiers + 1
                        If FP.bRecurse Then SearchForFiles sRoot & TrimNull(WFD.cFileName) & vbBackSlash
                    End If
                Else
                    If TrimNull(WFD.cFileName) <> sNomFichierFusion Then
                        If MatchSpec(WFD.cFileName, FP.sFileNameExt) Then
                            FP.nCount = FP.nCount + 1
                            ShDatas.Cells(FP.nCount + RDepart - 1, 2) = sRoot & TrimNull(WFD.cFileName)
                        End If
                    End If
                End If
                FP.nSearched = FP.nSearched + 1
                'Application.StatusBar = FP.nSearched & " / " & FP.nCount
            Loop While FindNextFile(hFile, WFD)
        End If
        FindClose hFile
    End Sub
     
    Sub SelDossierRacine()
    Dim sChemin As String
        sChemin = ThisWorkbook.Path
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = sChemin & "\"
            .Title = "Sélectionner le Dossier Racine"
            .AllowMultiSelect = False
            .InitialView = msoFileDialogViewDetails
            .ButtonName = "Sélection Dossier"
            .Show
            If .SelectedItems.Count > 0 Then
                ShDatas.Range("B2").Select
                DoEvents
                Rch .SelectedItems(1)
                'Tri
            End If
        End With
    End Sub
     
    Private Sub Tri()
    Dim LastRow As Long
        LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row
        ShDatas.Range("B6:B" & LastRow).Sort Key1:=ShDatas.Range("B6"), Order1:=xlAscending, Header:=xlGuess, _
                OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        ShDatas.Range("B2").Select
    End Sub
     
    Private Function TrimNull(startStr As String) As String
        TrimNull = Left$(startStr, lstrlen(StrPtr(startStr)))
    End Function
     
    Sub Usf()
        UserForm1.Show vbModeless
    End Sub
    dans un module standard baptisé mFusion
    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
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    Option Explicit
     
    Sub FusionPdf()
    Dim LastRow As Long, i As Long
    Dim Fichiers() As Variant
    Dim sFichier As String
    Dim pdf As Object
    Dim Debut As Currency, Fin As Currency, Freq As Currency
     
        Application.StatusBar = ""
        QueryPerformanceCounter Debut
        LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row
        If LastRow < RDepart Then Exit Sub
     
        Set pdf = CreateObject("pdfforge.Pdf.Pdf")
        For i = RDepart To LastRow
            sFichier = ShDatas.Range("B" & i)
            ReDim Preserve Fichiers(i - RDepart)
            Fichiers(i - RDepart) = sFichier
        Next i
     
        '        Public Sub MergePDFFiles ( _
        '            ByRef sourceFilenames As Object(), _
        '            destinationFilename As String, _
        '            FilenamesAsBookmarks As Boolean _
        '        )
     
        pdf.MergePDFFiles_2 Fichiers, ThisWorkbook.Path & "\" & sNomFichierFusion, True
        PosBoutons
        QueryPerformanceCounter Fin
        QueryPerformanceFrequency Freq
        Application.StatusBar = FormatNumber((Fin - Debut) / Freq, 2) & " s"
     
        Erase Fichiers
        Set pdf = Nothing
    End Sub
     
    Sub PosBoutons(Optional Dummy As String)
    Dim T As Range
        With ShDatas
            .Activate
            .Rows(1).RowHeight = 12.75
     
            Set T = .Cells(1, 3)
            With .Buttons("btnListe")
                .Left = T.Left + 3
                .Top = T.Top + ShDatas.Rows(1).RowHeight + 2
                .Width = 100
                .Height = 2 * Rows(1).RowHeight - 5
            End With
     
            With .Buttons("btnFusion")
                .Left = ShDatas.Buttons("btnListe").Left + ShDatas.Buttons("btnListe").Width + 5
                .Top = ShDatas.Buttons("btnListe").Top
                .Width = ShDatas.Buttons("btnListe").Width + 30
                .Height = ShDatas.Buttons("btnListe").Height
            End With
     
            With .Buttons("btnEffacer")
                .Left = ShDatas.Buttons("btnFusion").Left + ShDatas.Buttons("btnFusion").Width + 20
                .Top = ShDatas.Buttons("btnFusion").Top
                .Width = 50
                .Height = ShDatas.Buttons("btnFusion").Height
            End With
     
            With .Shapes("chkRecur")
                .Left = ShDatas.Shapes("btnListe").Left
                .Top = ShDatas.Shapes("btnListe").Top + ShDatas.Shapes("btnListe").Height + 5
                .Width = ShDatas.Buttons("btnListe").Width
                .Height = ShDatas.Buttons("btnListe").Height
            End With
        End With
    End Sub
    dans module standard baptisé mGlob
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    Option Explicit
     
    Public Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
    Public Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
     
    Public sRch As String
    Public Const sNomFichierFusion As String = "Liste Excel Fusion PDFs.Pdf"
    Public Const RDepart = 6
      2  0

  9. #89
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    Acrobat Fusion des fichiers PDF d'un dossier avec recherche récursive ou non des fichiers
    On reprend le code PDFCreator précédent
    en remplaçant la procédure FusionPdf du module mFusion par le code suivant :

    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
    60
    61
    Sub FusionPdf()
    Dim LastRow As Long, i As Long
    Dim Fichiers() As Variant
    Dim sFichier As String
    Dim Debut As Currency, Fin As Currency, Freq As Currency
    Dim PDDocDestination As Object  
    Dim PDDocSource As Object        
     
        Application.StatusBar = ""
        QueryPerformanceCounter Debut
        LastRow = ShDatas.Range("B" & Rows.Count).End(xlUp).Row
        If LastRow < RDepart Then Exit Sub
     
        For i = RDepart To LastRow
            sFichier = ShDatas.Range("B" & i)
            ReDim Preserve Fichiers(i - RDepart)
            Fichiers(i - RDepart) = sFichier
        Next i
     
        Set PDDocDestination = CreateObject("AcroExch.PDDoc")
        Set PDDocSource = CreateObject("AcroExch.PDDoc")
     
        With PDDocDestination
            .Create
            .Open (ThisWorkbook.Path & "\" & sNomFichierFusion)
        End With
     
        For i = LBound(Fichiers) To UBound(Fichiers)
            PDDocSource.Open (Fichiers(i))
     
            '  Paramètres :
            '   1 : Page du Document Destination après laquelle l'insertion sera faite.
    		'			La 1ere page est 0.
            '   2 : Document Source contenant les pages à insérer.
            '   3 : La 1ere page à être insérée dans le Document Destination 
    		'			à partir du Document Source
            '   4 : Le nombre de pages à insérer.
            '   5 : Si nombre > 0 les bookmarks sont copiés, si 0 ils ne le sont pas.
     
            PDDocDestination.InsertPages PDDocDestination.GetNumPages - 1, _
                    PDDocSource, _
                    0, _
                    PDDocSource.GetNumPages, _
                    1
     
        With PDDocDestination
            .Save 1, ThisWorkbook.Path & "\" & sNomFichierFusion
            .Close
        End With
     
        Set PDDocSource = Nothing
        Set PDDocDestination = Nothing
     
        QueryPerformanceCounter Fin
        QueryPerformanceFrequency Freq
        Application.StatusBar = FormatNumber((Fin - Debut) / Freq, 2) & " s"
     
        Erase Fichiers
        PosBoutons
        ShDatas.Range("B2").Select
    End Sub
      2  0

  10. #90
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    Une liste des contributions à jour pour Excel / Word / PDF avec Adobe Acrobat Pro et PDFCreator au 23 Avril 2014 au format xls avec les liens et intitulés des différents posts

    PS : Les colonnes D et E sont masquées ( pour encombrement visuel ... ) et contiennent les infos nécessaires pour créer les liens dans la colonne B.
    Fichiers attachés Fichiers attachés
      4  0

  11. #91
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    VBA Excel Dans le code de PDFCreator Fusion des fichiers PDF d'un dossier avec recherche récursive ou non de ces fichiers.

    On peut rajouter la possibilité de copier/coller dans la TextBox de l'UserForm via le menu contextuel ( clic droit ).

    Pour cela ajouter dans un module standard que l'on baptisera mPopupMenu.

    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
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    207
    208
    209
    210
    211
    212
    213
    214
    215
    216
    217
    218
    219
    220
    221
    222
    223
    224
    225
    226
    227
    228
    229
    230
    231
    232
    233
    234
    235
    236
    237
    238
    239
    240
    241
    242
    243
    244
    245
    246
    247
    248
    249
    250
    251
    252
    253
    254
    255
    256
    257
    258
    259
    260
    261
    262
    263
    264
    265
    266
    267
    268
    269
    270
    271
    272
    273
    274
    275
    276
    277
    278
    279
    280
    281
    Option Explicit
     
    '   http://word.mvps.org/faqs/userforms/AddRightClickMenu.htm
     
    ' Required API declarations
    Private Declare Function CreatePopupMenu Lib "user32" () As Long
    Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
    Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
    Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
     
    ' Type required by TrackPopupMenu although this is ignored !!
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
     
    ' Type required by InsertMenuItem
    Private Type MENUITEMINFO
        cbSize As Long
        fMask As Long
        fType As Long
        fState As Long
        wID As Long
        hSubMenu As Long
        hbmpChecked As Long
        hbmpUnchecked As Long
        dwItemData As Long
        dwTypeData As String
        cch As Long
    End Type
     
    ' Type required by GetCursorPos
    Private Type POINTAPI
        X As Long
        Y As Long
    End Type
     
    ' Constants required by TrackPopupMenu
    Private Const TPM_LEFTALIGN = &H0&
    Private Const TPM_TOPALIGN = &H0
    Private Const TPM_RETURNCMD = &H100
    Private Const TPM_RIGHTBUTTON = &H2&
     
    ' Constants required by MENUITEMINFO type
    Private Const MIIM_STATE = &H1
    Private Const MIIM_ID = &H2
    Private Const MIIM_TYPE = &H10
    Private Const MFT_STRING = &H0
    Private Const MFT_SEPARATOR = &H800
    Private Const MFS_DEFAULT = &H1000
    Private Const MFS_ENABLED = &H0
    Private Const MFS_GRAYED = &H1
     
    ' Contants defined by me for menu item IDs
    Private Const ID_Cut = 101
    Private Const ID_Copy = 102
    Private Const ID_Paste = 103
    Private Const ID_Delete = 104
    Private Const ID_SelectAll = 105
     
    ' Variables declared at module level
    Private FormCaption As String
    Private Cut_Enabled As Long
    Private Copy_Enabled As Long
    Private Paste_Enabled As Long
    Private Delete_Enabled As Long
    Private SelectAll_Enabled As Long
     
    Public Sub ShowPopup(oForm As UserForm, strCaption As String, X As Single, Y As Single)
    Dim oControl As MSForms.TextBox
    Static click_flag As Long
     
        ' The following is required because the MouseDown event
        ' fires twice when right-clicked !!
        click_flag = click_flag + 1
     
        ' Do nothing on first firing of MouseDown event
        If (click_flag Mod 2 <> 0) Then Exit Sub
     
        ' Set object reference to the textboxthat was clicked
        Set oControl = oForm.ActiveControl
     
        ' If click is outside the textbox, do nothing
        If X > oControl.Width Or Y > oControl.Height Or X < 0 Or Y < 0 Then Exit Sub
     
        ' Retrieve caption of UserForm for use in FindWindow API
        FormCaption = strCaption
     
        ' Call routine that sets menu items as enabled/disabled
        EnableMenuItems oForm
     
        ' Call function that shows the menu and return the ID
        ' of the selected menu item. Subsequent action depends
        ' on the returned ID.
        Select Case GetSelection()
            Case ID_Cut
                oControl.Cut
            Case ID_Copy
                oControl.Copy
            Case ID_Paste
                oControl.Paste
            Case ID_Delete
                oControl.SelText = ""
            Case ID_SelectAll
                With oControl
                    .SelStart = 0
                    .SelLength = Len(oControl.Text)
                End With
        End Select
    End Sub
     
    Private Sub EnableMenuItems(oForm As UserForm)
    Dim oControl As MSForms.TextBox
    Dim oData As DataObject
    Dim testClipBoard As String
     
        On Error Resume Next
     
        ' Set object variable to clicked textbox
        Set oControl = oForm.ActiveControl
     
        ' Create DataObject to access the clipboard
        Set oData = New DataObject
     
        ' Enable Cut/Copy/Delete menu items if text selected
        ' in textbox
        If oControl.SelLength > 0 Then
            Cut_Enabled = MFS_ENABLED
            Copy_Enabled = MFS_ENABLED
            Delete_Enabled = MFS_ENABLED
        Else
            Cut_Enabled = MFS_GRAYED
            Copy_Enabled = MFS_GRAYED
            Delete_Enabled = MFS_GRAYED
        End If
     
        ' Enable SelectAll menu item if there is any text in textbox
        If Len(oControl.Text) > 0 Then
            SelectAll_Enabled = MFS_ENABLED
        Else
            SelectAll_Enabled = MFS_GRAYED
        End If
     
        ' Get data from clipbaord
        oData.GetFromClipboard
     
        ' Following line generates an error if there
        ' is no text in clipboard
        testClipBoard = oData.GetText
     
        ' If NO error (ie there is text in clipboard) then
        ' enable Paste menu item. Otherwise, diable it.
        If Err.Number = 0 Then
            Paste_Enabled = MFS_ENABLED
        Else
            Paste_Enabled = MFS_GRAYED
        End If
     
        ' Clear the error object
        Err.Clear
     
        ' Clean up object references
        Set oControl = Nothing
        Set oData = Nothing
    End Sub
     
    Private Function GetSelection() As Long
    Dim menu_hwnd As Long
    Dim form_hwnd As Long
    Dim oMenuItemInfo1 As MENUITEMINFO
    Dim oMenuItemInfo2 As MENUITEMINFO
    Dim oMenuItemInfo3 As MENUITEMINFO
    Dim oMenuItemInfo4 As MENUITEMINFO
    Dim oMenuItemInfo5 As MENUITEMINFO
    Dim oMenuItemInfo6 As MENUITEMINFO
    Dim oRect As RECT
    Dim oPointAPI As POINTAPI
     
        ' Find hwnd of UserForm - note different classname
        ' 97 vs 2007
        #If VBA6 Then
            form_hwnd = FindWindow("ThunderDFrame", FormCaption)
        #Else
            form_hwnd = FindWindow("ThunderXFrame", FormCaption)
        #End If
     
        ' Get current cursor position
        ' Menu will be drawn at this location
        GetCursorPos oPointAPI
     
        ' Create new popup menu
        menu_hwnd = CreatePopupMenu
     
        ' Intitialize MenuItemInfo structures for the 6
        ' menu items to be added
     
        ' Cut
        With oMenuItemInfo1
            .cbSize = Len(oMenuItemInfo1)
            .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
            .fType = MFT_STRING
            .fState = Cut_Enabled
            .wID = ID_Cut
            .dwTypeData = "Couper"
            .cch = Len(.dwTypeData)
        End With
     
        ' Copy
        With oMenuItemInfo2
            .cbSize = Len(oMenuItemInfo2)
            .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
            .fType = MFT_STRING
            .fState = Copy_Enabled
            .wID = ID_Copy
            .dwTypeData = "Copier"
            .cch = Len(.dwTypeData)
        End With
     
        ' Paste
        With oMenuItemInfo3
            .cbSize = Len(oMenuItemInfo3)
            .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
            .fType = MFT_STRING
            .fState = Paste_Enabled
            .wID = ID_Paste
            .dwTypeData = "Coller"
            .cch = Len(.dwTypeData)
        End With
     
        ' Separator
        With oMenuItemInfo4
            .cbSize = Len(oMenuItemInfo4)
            .fMask = MIIM_TYPE
            .fType = MFT_SEPARATOR
        End With
     
        ' Delete
        With oMenuItemInfo5
            .cbSize = Len(oMenuItemInfo5)
            .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
            .fType = MFT_STRING
            .fState = Delete_Enabled
            .wID = ID_Delete
            .dwTypeData = "Supprimer"
            .cch = Len(.dwTypeData)
        End With
     
        ' SelectAll
        With oMenuItemInfo6
            .cbSize = Len(oMenuItemInfo6)
            .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
            .fType = MFT_STRING
            .fState = SelectAll_Enabled
            .wID = ID_SelectAll
            .dwTypeData = "Tout Sélectionner"
            .cch = Len(.dwTypeData)
        End With
     
        ' Add the 6 menu items
        InsertMenuItem menu_hwnd, 1, True, oMenuItemInfo1
        InsertMenuItem menu_hwnd, 2, True, oMenuItemInfo2
        InsertMenuItem menu_hwnd, 3, True, oMenuItemInfo3
        InsertMenuItem menu_hwnd, 4, True, oMenuItemInfo4
        InsertMenuItem menu_hwnd, 5, True, oMenuItemInfo5
        InsertMenuItem menu_hwnd, 6, True, oMenuItemInfo6
     
        ' Return the ID of the item selected by the user
        ' and set it the return value of the function
        GetSelection = TrackPopupMenu _
                (menu_hwnd, _
                TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, _
                oPointAPI.X, oPointAPI.Y, _
                0, form_hwnd, oRect)
     
        ' Destroy the menu
        DestroyMenu menu_hwnd
    End Function
    on rajoutera dans le code de l'UserForm.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    Private Sub txtBox_MouseDown(ByVal Button As Integer, _
            ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        ' If right-button clicked
        If Button = 2 Then
            ShowPopup Me, Me.Caption, X, Y
        End If
    End Sub
      2  0

  12. #92
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    Remarque Problèmes lors de l'usage des SendKeys si Acrobat Reader 10 et +

    l'usage des Sendkeys pose des problèmes à partir du Reader 10 et +

    Copier/Coller le texte d'un PDF dans une feuille Excel via des SendKeys

    pour le Reader :
    Dans le menu Edition/Préférences catégories : Protection (renforcée)
    Décocher "Activer le mode protégé au démarrage".

    pour Acrobat il en est de même via le menu idoine.
      2  0

  13. #93
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    Acrobat Reader Retrouver le chemin du Reader via la base de registre
    Adapté d'un code initial de John de Kraft

    dans un module standard baptisé mAcro
    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
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    Option Explicit
     
    Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
            (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
            pType As Long, lpData As Any, lpcbData As Long) As Long
    Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
            (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
            ByVal samDesired As Long, phkResult As Long) As Long
    Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
     
    Private Const SYNCHRONIZE As Long = &H100000
    Private Const STANDARD_RIGHTS_ALL As Long = &H1F0000
    Private Const KEY_QUERY_VALUE As Long = &H1
    Private Const KEY_SET_VALUE As Long = &H2
    Private Const KEY_CREATE_SUB_KEY As Long = &H4
    Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
    Private Const KEY_NOTIFY As Long = &H10
    Private Const KEY_CREATE_LINK As Long = &H20
    Private Const KEY_ALL_ACCESS As Long = ((STANDARD_RIGHTS_ALL Or _
            KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or _
            KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
    Private Const ERROR_SUCCESS As Long = 0
    Private Const HKEY_CLASSES_ROOT As Long = &H80000000
     
    Private Function GetRegistryString(lngKey As Long, strSubKey As String, strValue As String) As String
    Dim lngDataType As Long
    Dim lngDataLength As Long
    Dim strDataString As String
    Dim lngResult As Long
    Dim lngHandle As Long
    Const StringLength = 150
     
        strDataString = Space(StringLength)
        lngDataType = 0
        lngDataLength = CLng(StringLength)
        lngResult = RegOpenKeyEx(lngKey, strSubKey, 0, KEY_ALL_ACCESS, lngHandle)
        If lngResult < ERROR_SUCCESS Then
            GetRegistryString = "Error"
            Exit Function
        End If
        lngResult = RegQueryValueEx(lngHandle, strValue, 0, lngDataType, ByVal strDataString, lngDataLength)
        If lngResult < ERROR_SUCCESS Then
            GetRegistryString = "Error"
            lngResult = RegCloseKey(lngHandle)
            Exit Function
        End If
        strDataString = Left$(strDataString, lngDataLength)
     
        If Len(strDataString) > 0 Then
            If Left$(strDataString, 1) = Chr(34) Then strDataString = Right$(strDataString, Len(strDataString) - 1)
        End If
     
        If Right$(strDataString, 3) < "exe" And Len(strDataString) > 0 Then
            strDataString = Left$(strDataString, Len(strDataString) - 1)
            If Len(strDataString) > 0 Then
                If Right$(strDataString, 1) = Chr(34) Then strDataString = Left$(strDataString, Len(strDataString) - 1)
            End If
            If Right$(strDataString, 3) = "exe" Then
                GetRegistryString = Left$(strDataString, lngDataLength)
            Else
                GetRegistryString = "Error"
            End If
            lngResult = RegCloseKey(lngHandle)
        End If
    End Function
     
    Function GetAcrobatReaderShellPath() As String
        GetAcrobatReaderShellPath = GetRegistryString(HKEY_CLASSES_ROOT, "Software\Adobe\Acrobat\Exe", "")
    End Function
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    .....
        sAcro = GetAcrobatReaderShellPath
     
        If ExistenceFichier(sAcro) = False Then
            MsgBox "Le chemin d'Acrobat Reader est erroné : il faudra le corriger manuellement" & vbCrLf & vbCrLf & _
                    "dans la procédure xxxxx" & vbCrLf & "à sAcro = .....", vbInformation + vbOKOnly, "Chemin du Reader erroné"
            Exit Sub
        End If
    .....
     
    Private Function ExistenceFichier(sFichier As String) As Boolean
        ExistenceFichier = Dir$(sFichier) <> ""
    End Function
    pour XP et le Reader 11.x : GetAcrobatReaderShellPath retourne "C:\Program Files\Adobe\Reader 11.0\Reader\AcroRd32.exe"
      1  0

  14. #94
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    Remarque : Sauvegarde en Texte avec Acrobat et Acrobat Reader

    Sous Acrobat il existe 2 options de sauvegarde en Texte ( Plain ) et ( Accessible )
    avec le Reader une seule ( Accessible ), dans tous les cas opter pour Accessible.

    Un doc pdf comporte des tags qui permettent de connaitre l'ordre de lecture du texte.
    "Accessible" seront des documents incluants ces tags contrairement à "Plain".

    Concernant Sauvegarder un fichier PDF au format TEXTE via VBA Excel opter pour l"option com.adobe.acrobat.accesstext.
      1  0

  15. #95
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    Remarque Utilisation de Sleep si usage de SendKeys

    Acrobat Reader Copier/Coller le texte d'un PDF dans une feuille Excel via des SendKeys

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
      .....
                Clavier
                Sleep 250
     
                Shell sAcro & " " & sFichier, vbNormalFocus
     
                SendKeys "^a", True
                SendKeys "^c", True
                SendKeys "^q", True
                Sleep 250
    	    .....
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
      .....
    	    Clavier
                Sleep 250
     
                Shell sAcro & " " & sFichier, vbNormalFocus
                Sleep 5000
     
                SendKeys "^a", True
                Sleep 5000
                SendKeys "^c", True
                Sleep 5000
                SendKeys "^q", True
                Sleep 5000
                .....
    Ces valeurs sont à ajuster suivant la config, cela permet d'éviter des messages du style "la méthode Paste de l'objet _Worksheet a échoué".
    Fichiers attachés Fichiers attachés
      1  0

  16. #96
    Futur Membre du Club
    Homme Profil pro
    Étudiant
    Inscrit en
    juin 2014
    Messages
    2
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 32
    Localisation : France, Pyrénées Atlantiques (Aquitaine)

    Informations professionnelles :
    Activité : Étudiant

    Informations forums :
    Inscription : juin 2014
    Messages : 2
    Points : 5
    Points
    5
    Par défaut imprimer des pages d'un fichier pdf via excel
    Bonjour KIKI29 et les autres ,

    je viens de voir tout tes codes mais je n'ai malheureusement pas réussi à en adapter un pour ce que je dois faire.
    Mon chef me demande un fichier excel avec differents boutons qui sont chacun reliés à des pages précis d'un fichier PDF. Par exemple, le bouton "Traca 1" imprime les pages 3 à 5 de mon fichier PDF, le bouton "Traca 2" imprime les pages 8 à 13" etc.
    J'arrive à relier un bouton avec mon pdf mais impossible d'imprimer les pages souhaitées.
    Quelqu'un aurait-il une idée afin de me débloquer? mon chef commence à s'impatienter :s

    Merci beaucoup à tous ceux qui pourront m'aider
      0  0

  17. #97
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    Acrobat Imprimer un PDF de la page x à y

    Infos tirées de la doc : AVDoc.PrintPages firstPage , lastPage , psLevel , binaryOK , ShrinkToFit

    firstPage The first page to print. The first page in a PDDoc is page 0.
    lastPage The last page to print.
    psLevel if 1, PostScript Level 1 operators are used. If 2, PostScript Level 2 operators are also used.
    binaryOK If true, binary data may be included in the PostScript program.If false, all data is encoded as 7-bit ASCII.
    ShrinkToFit If true, the page is shrunk (if necessary) to fit within the imageable area of the printed page.If false, it is not.
    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
    Option Explicit
     
    Sub Tst()
    Dim AcroApp As Object
    Dim AVDoc As Object
     
        Set AcroApp = CreateObject("AcroExch.App")
        Set AVDoc = CreateObject("AcroExch.AVDoc")
     
        AVDoc.Open "C:\Essai.pdf", ""
        AVDoc.PrintPages 1, 2, 2, True, True
        AVDoc.Close True
     
        AcroApp.Exit
     
        Set AVDoc = Nothing
        Set AcroApp = Nothing
    End Sub
      2  0

  18. #98
    Futur Membre du Club
    Homme Profil pro
    Étudiant
    Inscrit en
    juin 2014
    Messages
    2
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 32
    Localisation : France, Pyrénées Atlantiques (Aquitaine)

    Informations professionnelles :
    Activité : Étudiant

    Informations forums :
    Inscription : juin 2014
    Messages : 2
    Points : 5
    Points
    5
    Par défaut
    Merci beaucoup, c'est juste parfait, je l'ai essayé sur mon ordi perso hier soir il est nickel. Par contre au boulot je n'ai pas Acrobat Pro. Je vais voir avec le service info si ils possedent les licences. Il n'y a pas d'autre possibilité en ayant juste excel?
    En tout cas merci pour ta réactivité
      1  0

  19. #99
    Expert éminent sénior
    Avatar de kiki29
    Homme Profil pro
    ex Observeur CGG / Analyste prog.
    Inscrit en
    juin 2006
    Messages
    6 132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Finistère (Bretagne)

    Informations professionnelles :
    Activité : ex Observeur CGG / Analyste prog.

    Informations forums :
    Inscription : juin 2006
    Messages : 6 132
    Points : 11 270
    Points
    11 270
    Par défaut
    Acrobat Reader Imprimer un PDF de la page x à y via des SendKeys

    Ajouter une UserForm puis la supprimer pour référencer Microsoft Forms 2.0 Object Library

    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
    Option Explicit
     
    Sub Tst()
    Dim sAcro As String, sFichier As String
    Dim Clip As MSForms.DataObject, sPages As String
     
        sPages = "1;3-4"
     
        Set Clip = New MSForms.DataObject
        Clip.Clear
        Clip.SetText sPages, 1
        Clip.PutInClipboard
     
        sAcro = "C:\Program Files\Adobe\Reader 11.0\Reader\AcroRd32.exe"
        sFichier = "C:\Essai.pdf"
     
        Shell sAcro & " " & sFichier, vbNormalFocus
        'Sleep 500
     
        SendKeys "^p", True
        SendKeys "%g", True
        SendKeys "{TAB}", True
        SendKeys "^v", True
        SendKeys "{ENTER}", True
        'Sleep 500
     
        KillAcrobatReader
        Set Clip = Nothing
    End Sub
     
    Private Sub KillAcrobatReader()
        Shell "Taskkill /im Acrobat.exe /f", 0
    End Sub
    Il est probable que l'utilisation de Sleep soit nécessaire, et donc l'ajout de la déclaration :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
      2  0

  20. #100
    Expert confirmé Avatar de illight
    Homme Profil pro
    Analyste décisionnel
    Inscrit en
    septembre 2005
    Messages
    2 335
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 41
    Localisation : France, Bas Rhin (Alsace)

    Informations professionnelles :
    Activité : Analyste décisionnel
    Secteur : Service public

    Informations forums :
    Inscription : septembre 2005
    Messages : 2 335
    Points : 4 293
    Points
    4 293
    Par défaut
    Bonjour,


    Je viens de lire ces posts ici et ici : ces 2 points de cféation de signets dans Excel m'intéresse au plus haut point.

    Seulement, par rapport à ce que j'ai pu lire, j'ai l'impression qu'il faut une version particulière d'Excel, et Adobe Reader ne suffit pas.
    Pouvez-vous me confirmer ou m'infirmer (ce qui m'arrangerai ) ?

    J'ai un énorme fichier Excel, avec plusieurs onglets, qui correspondraient aux différents signets de mon fichier PDF final, mais je ne sais pas si c'est possible avec les macros présentées, et seulement Adobe Reader (et PDFCreator mais bon..).

    En vous remerciant par avance pour vos réponses
    1. Avant de poster, et http://www.developpez.com/sources/
    2. Lors du post, n'oubliez pas, si besoin les balises CODE => voir ici pour l'utilisation
    3. N'oubliez pas le
    4. N'oubliez pas le si la réponse vous a été utile !
      0  0

Discussions similaires

  1. resultat sur un fichier excel,word,pdf
    Par harakatyouness dans le forum C#
    Réponses: 3
    Dernier message: 08/08/2007, 16h45
  2. convertir en pdf avec adobe VBA
    Par sophie.baron dans le forum Général VBA
    Réponses: 1
    Dernier message: 26/03/2007, 14h49
  3. Problème avec adobe acrobat reader
    Par Rabie de OLEP dans le forum Windows XP
    Réponses: 4
    Dernier message: 24/03/2007, 20h50
  4. Problème avec Adobe acrobat reader
    Par castelm dans le forum Autres Logiciels
    Réponses: 4
    Dernier message: 08/03/2007, 21h19
  5. Impression .PDF avec adobe
    Par popo68 dans le forum Access
    Réponses: 2
    Dernier message: 26/02/2007, 12h19

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo