Option Explicit
Const HWND_BROADCAST = &HFFFF
Const WM_WININICHANGE = &H1A

'''""""""""""""""""""""""""""""""""""""""""""""""""""'''
'
'                    API kernel32.dll
'
'''""""""""""""""""""""""""""""""""""""""""""""""""""'''
' lire dans un fichier INI
Private Declare Function apiGetPrivateProfileString Lib "kernel32" _
        Alias "GetPrivateProfileStringA" ( _
        ByVal lpApplicationName As String, _
        ByVal lpKeyName As Any, ByVal lpDefault As String, _
        ByVal lpReturnedString As String, ByVal nSize As Long, _
        ByVal lpFileName As String) As Long

' renvoyer le répertoire Windows
Private Declare Function apiGetWindowsDirectory Lib "kernel32" _
        Alias "GetWindowsDirectoryA" ( _
        ByVal lpBuffer As String, ByVal nSize As Long) As Long

' écrire dans un fichier INI
Private Declare Function apiWritePrivateProfileString Lib "kernel32" _
        Alias "WritePrivateProfileStringA" ( _
        ByVal lpApplicationName As String, _
        ByVal lpKeyName As Any, ByVal lpString As Any, _
        ByVal lpFileName As String) As Long

'''""""""""""""""""""""""""""""""""""""""""""""""""""'''
'
'                     API user32.dll
'
'''""""""""""""""""""""""""""""""""""""""""""""""""""'''
' envoyer un message qui indique à Windows la mise à jour de WIN.INI
Private Declare Function apiSendMessage Lib "user32" _
        Alias "SendMessageA" ( _
        ByVal hwnd As Long, ByVal wMsg As Long, _
        ByVal wParam As Integer, ByVal lParam As Any) As Long


Private strPath As String
Private lngNC As Long
Private strRet As String

Sub SwitchDefaultPrinter(Nom As String)
    ' modifie le nom de l'imprimante par défaut
    
    strPath = String(260, 0)
    ' récupère le chemin de win.ini
    strPath = Left$(strPath, apiGetWindowsDirectory(strPath, Len(strPath))) + "\win.ini"
    strRet = String(255, 0)
    lngNC = apiGetPrivateProfileString("Devices", Nom, "", strRet, 255, strPath)
    strRet = Left(strRet, lngNC)
    ' écrit dans win.ini le nom de l'imprimante souhaitée
    apiWritePrivateProfileString "windows", "device", Nom & "," & strRet, strPath
    ' signale à MS Windows de prendre en compte la modification de win.ini
    apiSendMessage HWND_BROADCAST, WM_WININICHANGE, 0, "windows"

End Sub

Function GetDefaultPrinter() As String
    ' renvoie le nom de l'imprimante par défaut
    
    strPath = String(260, 0)
    strPath = Left$(strPath, apiGetWindowsDirectory(strPath, Len(strPath))) + "\win.ini"
    strRet = String(255, 0)
    lngNC = apiGetPrivateProfileString("windows", "device", "", strRet, 255, strPath)
    strRet = Left(strRet, lngNC)
    lngNC = InStr(strRet, ",")
    GetDefaultPrinter = Left(strRet, lngNC - 1)

End Function

Function getPDF(ByVal strReport As String, _
                Optional ByVal allPages As Integer = acPrintAll, _
                Optional ByVal pStart As Integer, _
                Optional ByVal pEnd As Integer)

Dim strOldPrinter As String
Dim strPdfPrinter As String
Dim dblStamp As Double

' récupération de l'imprimante par défaut
strOldPrinter = GetDefaultPrinter

' attribution de l'imprimante PDF
strPdfPrinter = "PDFCreator"
SwitchDefaultPrinter strPdfPrinter

' récupération de la date / heure courante
dblStamp = Now
' ajout du document dans la file d'attente
addDocument strReport & IIf(allPages <> acPrintAll, " [" & pStart & "-" & pEnd & "]", ""), dblStamp

' ouverture de l'état par automation
fOpenRemoteReport workDB.Name, strReport, _
                  acViewPreview, allPages, _
                  IIf(allPages <> acPrintAll, pStart, 1), IIf(allPages <> acPrintAll, pEnd, 9999)

' réattribution de l'imprimante par défaut
SwitchDefaultPrinter strOldPrinter

' gestion de la file d'attente des documents
ScanPDFfiles

End Function

Function addDocument(ByVal strDocName As String, ByVal dblStamp As Double)
   ' ajouter un document dans la file d'attente

   If Not isTable("tblPDFdoc") Then
       ' création de table
       DoCmd.RunSQL "CREATE TABLE tblPDFdoc (doc TEXT, tim TEXT, done YESNO);"
   End If

   ' SQL d'insertion
   DoCmd.RunSQL "INSERT INTO tblPDFdoc VALUES (""" & strDocName & """, """ & Format(dblStamp, "yyyymmddhhnnss") & """, 0);"

End Function

Function isTable(tblName As String) As Boolean
   ' tester l'existence d'une table

   On Error GoTo istblerr

   Debug.Print CurrentDb.TableDefs(tblName).Name
   isTable = True
   Exit Function

   istblerr:
   isTable = False
   Err.Clear

End Function

Sub ScanPDFfiles()
' traitement des fichiers en file d'attente

Dim strPath As String, currFile As String
Dim rec As DAO.Recordset
Dim fso As New FileSystemObject
Dim intCount As Integer

On Error GoTo scanPDF

intCount = 0
' nous avons stocké le chemin de une propriété de la base
strPath = CurrentDb.Properties("workPath")
Set rec = CurrentDb.OpenRecordset("SELECT * FROM tblPDFdoc WHERE done = False ORDER BY tim;", dbOpenDynaset)
Do While Not rec.EOF
    ' fonction pour trouver le fichier dont la date est la plus proche
    '  de la date de demande d'édition
    currFile = GetFirstFileName(rec!tim)
    If Len(currFile) > 0 Then
        ' si le fichier a été trouvé on le renomme
        fso.MoveFile strPath & currFile, strPath & rec!doc & IIf(intCount = 0, "", intCount) & ".pdf"
        intCount = 0
        ' mise à jour de la table de la file d'attente
        rec.Edit
            rec!done = True
        rec.Update
    End If
    rec.MoveNext
Loop

rec.Close
Set rec = Nothing
Set fso = Nothing

Exit Sub

' traitement d'erreurs
scanPDF:
If Err.Number = 58 Then
    ' si le fichier existe déjà
    '  on rajoute un numéro au nom ...
    intCount = intCount + 1
    Resume
Else
    MsgBox Err.Number & " - " & Err.Description
    Err.Clear
    Resume Next
End If

Set fso = Nothing

End Sub

Function GetFirstFileName(ByVal strStamp As String) As String
' fonction renvoyant le nom du fichier dont la date est la plus proche
'  de la date de demande d'édition

Dim strPath As String
Dim strFic As String
Dim dblTargetFic As Double

' valeur maximum
dblTargetFic = CDbl("29991231235959")

' nous avons stocké le chemin de une propriété de la base
strPath = CurrentDb.Properties("workPath")

strFic = Dir(strPath & Left(strStamp, 4) & "*.pdf")
Do While Len(strFic) > 0
    If CDbl(Left(strFic, Len(strFic) - 4)) >= CDbl(strStamp) Then
        ' parmi les fichiers dont la date est supérieure ou égale
        '  à la date de demande d'édition, on prend celle qui a la valeur
        '  minimale
        dblTargetFic = Minus(dblTargetFic, CDbl(Left(strFic, Len(strFic) - 4)))
    End If
    strFic = Dir
Loop

GetFirstFileName = IIf(dblTargetFic <> 29991231235959#, dblTargetFic & ".pdf", "")

End Function

Function Minus(vA, vB)
' trouver le minimum entre deux valeurs

If vA > vB Then
    Minus = vB
Else
    Minus = vA
End If

End Function

Function fOpenRemoteReport(ByVal strMDB As String, _
                           ByVal strReport As String, _
                           ByVal aMode, ByVal aPage, _
                           ByVal iStart As Integer, ByVal iEnd As Integer) As Boolean
Dim objAccess As Access.Application
Dim lngRet As Long

    ' gestion d'erreurs
    On Error GoTo fOpenRemoteReport_Err

    If Len(Dir(strMDB)) > 0 Then
        ' creation de l'objet Access
        Set objAccess = New Access.Application
        With objAccess
            'ouverture de la base
            .OpenCurrentDatabase strMDB
            'les commandes sont les memes que pour la base en cours
            ' hormis le "objAccess."
            ' ouverture de l'état
            .DoCmd.OpenReport strReport, aMode
            ' impression des pages
            .DoCmd.PrintOut aPage, iStart, iEnd, acHigh
            ' fermeture de l'état sans sauvegarde
            .DoCmd.Close acReport, strReport, acSaveNo
        End With
    End If

fOpenRemoteReport_Exit:
    ' libération des objets
    On Error Resume Next
    objAccess.Quit
    Set objAccess = Nothing
    Exit Function

fOpenRemoteReport_Err:
    fOpenRemoteReport = False
    Select Case Err.Number
        Case 7866:
            'mdb ouverte en mode exclusif
            MsgBox "The database you specified " & vbCrLf & strMDB & _
                vbCrLf & "is currently open in exclusive mode.  " & vbCrLf _
                & vbCrLf & "Please reopen in shared mode and try again", _
                vbExclamation + vbOKOnly, "Could not open database."
        Case 2103:
            'l'état n'existe pas
            MsgBox "The report '" & strReport & _
                        "' doesn't exist in the Database " _
                        & vbCrLf & strMDB, _
                        vbExclamation + vbOKOnly, "report not found"
        Case 7952:
            'l"utilisateur a fermé le fichier mdb
            fOpenRemoteReport = True
        Case Else:
            MsgBox "Error#: " & Err.Number & vbCrLf & Err.Description, _
                    vbCritical + vbOKOnly, "Runtime error"
    End Select
    Resume fOpenRemoteReport_Exit
End Function

"C:\Program Files\pdfmerge\pdftk.exe" A="D:\Temp\toto.pdf" B="D:\Temp\tata.pdf" C="D:\Temp\tutu.pdf"
             cat B A C1-2 
			 output "D:\Temp\Export.pdf"

CREATE TABLE tblPDFwork (id COUNTER, dnom TEXT, pfrom INTEGER, pto INTEGER, docorder INTEGER);

SELECT tblPDFwork.id, tblPDFwork.dnom, tblPDFwork.pfrom, tblPDFwork.pto, tblPDFwork.zorder
FROM tblPDFwork
ORDER BY tblPDFwork.zorder;

Private Sub Form_Load()
' dans le cas où la table n'existe pas, nous la créons.
If Not isTable("tblPDFwork") Then
    DoCmd.RunSQL "CREATE TABLE tblPDFwork (id COUNTER, dnom TEXT, pfrom INTEGER, pto INTEGER, zorder INTEGER);"
End If

' remplissage de la liste
FillList

End Sub

Sub FillList()
' remplissage de la liste des fichiers PDF dans notre répertoire de travail
Dim strPath As String
Dim strFic As String
Dim strSRC As String

strPath = "D:\Temp\"
strFic = Dir(strPath & "*.pdf")
Do While Len(strFic) > 0
    strSRC = strSRC & ";" & strFic
    strFic = Dir
Loop


Me.lstFiles.RowSource = Right(strSRC, Len(strSRC) - 1)

End Sub

Private Sub subfrmPDFwork_Exit(Cancel As Integer)
' lorsque le sous-form perd le focus, nous remettons à jour
'  utile en particulier lorsque l'utilisateur change l'ordre.
Me.subfrmPDFwork.Form.Requery

End Sub

Private Sub cmdAdd_Click()
' ajout d'une ligne par SQL INSERT
    If Len(Me.lstFiles) > 0 Then
        DoCmd.RunSQL "INSERT INTO tblPDFwork ( dnom , pfrom , pto ) " & _
                     "VALUES (""" & Me.lstFiles & """, " & _
                     IIf(Len(Me.txtFrom) > 0, Me.txtFrom, -1) & ", " & _
                     IIf(Len(Me.txtTo) > 0, Me.txtTo, -1) & ");"
        ' mise à jour du sous-formulaire de la liste de compilation
        Me.subfrmPDFwork.Form.Requery
    End If
    
End Sub

Private Sub cmdDel_Click()
' suppression de ligne sélectionnée
    If Len(Me.subfrmPDFwork.Form.Id) > 0 Then
        DoCmd.RunSQL "DELETE * FROM tblPDFwork WHERE id = " & Me.subfrmPDFwork.Form.Id & ";"
        ' mise à jour du sous-formulaire de la liste de compilation
        Me.subfrmPDFwork.Form.Requery
    End If

End Sub

Private Sub cmdGenerate_Click()

' déclarations
Dim rec As DAO.Recordset
Dim iCount As Integer
Dim strCommand As String
Dim strPath As String
Dim strCat As String
Dim strOutput As String
Dim strScript As String

' initialisations des variables
strPath = "D:\Temp\"
strCommand = """C:\Program Files\pdfmerge\pdftk.exe"" "
strCat = " cat "
strOutput = " output """ & strPath & Me.txtProjectName & ".pdf"""
iCount = 65

' ouverture du recordset sur la table de travail, tri en fonction du champ zorder
Set rec = CurrentDb.OpenRecordset("SELECT * FROM tblPDFwork ORDER BY zorder;", dbOpenSnapshot)

Do While Not rec.EOF
    ' en incrémentant iCount nous permettons d'afficher A, B, C etc.
    strCommand = strCommand & Chr(iCount) & "=""" & strPath & rec!dnom & """ "
    ' dans le cas où nous restreignons des pages
    '  nous accolons à la lettre la page de debut - page de fin
    strCat = strCat & Chr(iCount) & IIf(rec!pfrom <> -1, rec!pfrom & "-" & rec!pto, "") & " "
    iCount = iCount + 1
    rec.MoveNext
Loop
rec.Close

' concaténation des trois parties du script
strScript = strCommand & strCat & strOutput

' exécution
Shell strScript, vbHide

Set rec = Nothing

' remise à jour de la liste des pdf
FillList

End Sub