accesstoolbox/source/modules/AT_Pdf.bas

Option Compare Database

' ** Access Toolbox Module **
' on 2017-02-28,
' @author: Olivier Massot
' V 1.0

' Operations on PDF Files

' ! Requires AT_Access
' ! Requires PDF Creator 1.7.0

Public Function export_pdf(report_name As String, _
                            dir_path As String, _
                            Optional pdf_name As String = "", _
                            Optional filter As String = "", _
                            Optional replace As Boolean = True) As Boolean
  On Error GoTo err

  export_pdf = False

  If Not report_exists(report_name) Then GoTo errNotExist
  
  If Right(dir_path, 1) <> "\" Then dir_path = dir_path & "\"
  
  If Dir(dir_path, vbDirectory) = "" Then GoTo errDirNotExist
  
  If Not Len(pdf_name) > 0 Then pdf_name = report_name
  
  If Right(nomPDF, 4) <> ".pdf" Then pdf_name = pdf_name & ".pdf"

  If Dir(dir_path & pdf_name) <> "" Then
        If replace = False Then
          If MsgBox("Un fichier PDF portant ce nom existe déjà, voulez-vous l'écraser?", vbYesNo) = vbNo Then
             GoTo cancel_
          End If
        End If
        
        On Error GoTo errDelFile
        Kill repCible & nomPDF
        On Error GoTo err
  End If

  If Not report_is_opened(report_name) Then DoCmd.OpenReport nomEtat, acViewNormal, , filter, acHidden
  DoCmd.OutputTo acOutputReport, report_name, acFormatPDF, dir_path & pdf_name
  DoCmd.Close acReport, report_name, acSaveNo
  
  exportPDF = True

fin:
  Exit Function
errNotExist:
  MsgBox "Erreur: l'état demandé n'existe pas ('" & report_name & "')"
  GoTo fin
errDirNotExist:
  MsgBox "Erreur: le répertoire cible '" & repCible & "' n'existe pas, veuillez le créer ou contacter un administrateur."
  GoTo fin
cancel_:
  MsgBox "Export PDF annulé"
  GoTo fin
errDelFile:
  MsgBox "Impossible de supprimer le fichier existant, il est peut-être ouvert?" & vbNewLine & "Opération annulée"
  GoTo fin
err:
  MsgBox "Erreur de l'export PDF : " & vbNewLine & err.Description
  GoTo fin
End Function

Public Sub pdf_append(ByVal path_pdf1 As String, ByVal path_pdf2 As String, ByVal result_path As String)
'Créé le fichier PDF 'result_path' en indérant le PDF 2 à la suite du PDF 1
' usage:
' >>       pdf_append "C:\path\to\file1.pdf", "C:\path\to\file2.pdf", "C:\path\to\file1&2.pdf"

' ATTENTION: nécessite PDF Creator 1.7

    On Error GoTo err
    Dim oPdf As Object
    
    On Error GoTo errPdfforge
    Set oPdf = CreateObject("pdfforge.pdf.pdf")
    On Error GoTo err
    
    oPdf.MergePDFFiles_2 Array(path_pdf1, path_pdf2), result_path, True

fin:
    Exit Sub
err:
    MsgBox "Erreur lors de la fusion des pdfs: " & err.Description
    GoTo fin
errPdfforge:
    MsgBox "Erreur: Pdfforge 1.7 est nécessaire pour utiliser cette fonction, opération annulée." & vbNewLine & _
           "Essayez d'installer PDF Creator 1.7.0"
    GoTo fin
End Sub





Public Sub ExcelVersPDF(cheminExcel As String, Optional cheminPDF As String = "", Optional feuille As Integer = 1, Optional ecraser As Boolean = True)
  'exporte la page demandée du document excel en pdf
  
  '! Requires Micosoft Excel XX.X Object Library
  
  Dim objExcel As Excel.Application
  Dim objExcelDoc As Excel.Workbook
  Dim objExcelFeuille As Excel.Worksheet
  
  If Dir(cheminExcel) = "" Then GoTo errSource
  If Dir(repFichier(cheminPDF), vbDirectory) = "" Then GoTo errRepCible
  If Len(cheminPDF) = 0 Then cheminPDF = Split(cheminExcel, ".")(0) & ".pdf"
  If feuille < 1 Then feuille = 1
  
  If Right(cheminPDF, 4) <> ".pdf" Then cheminPDF = cheminPDF & ".pdf"
  If Dir(cheminPDF) <> "" Then
    If ecraser = False Then
      If MsgBox("Un fichier portant ce nom existe déjà, voulez-vous le remplacer", vbYesNo) = vbNo Then GoTo annule
    End If
    On Error GoTo errSuppr
    Kill cheminPDF
    On Error GoTo err
  End If

  Set objExcel = CreateObject("Excel.Application")
  objExcel.Visible = True
  Set objExcelDoc = objExcel.Workbooks.Open(cheminExcel)
  If Not objExcel Is Nothing Then
     objExcelDoc.ExportAsFixedFormat xlTypePDF, cheminPDF, xlQualityStandard, , , feuille, feuille, False
  End If

fin:
  On Error Resume Next
  objExcelDoc.Close False
  objExcel.Quit
  Set objExcelDoc = Nothing
  Set objExcel = Nothing
  Exit Sub
err:
  MsgBox "Erreur: " & err.Description
  GoTo fin
errSource:
  MsgBox "Erreur: Fichier Excel (.xls) introuvable"
  GoTo fin
errSuppr:
  MsgBox "Impossible de supprimer le fichier existant, il est peut-être ouvert?" & vbNewLine & "Opération annulée"
  GoTo fin
annule:
  MsgBox "Opération annulée"
  GoTo fin
errRepCible:
  MsgBox "Erreur: le répertoire cible n'existe pas, veuillez le créer ou prévenir un administrateur"
  GoTo fin
End Sub

Public Sub WordVersPDF(cheminWord As String, Optional cheminPDF As String, Optional ecraser As Boolean = True)

'exporte la page demandée du document word en pdf

  '! Requires Micosoft Word XX.X Object Library
  
  Dim objWord As Word.Application
  Dim objWordDoc As Word.Document

  If Dir(cheminWord) = "" Then GoTo errSource
  If Dir(repFichier(cheminPDF), vbDirectory) = "" Then GoTo errRepCible
  If Len(cheminPDF) = 0 Then cheminPDF = Split(cheminWord, ".")(0) & ".pdf"
  
  If Right(cheminPDF, 4) <> ".pdf" Then cheminPDF = cheminPDF & ".pdf"
  If Dir(cheminPDF) <> "" Then
    If ecraser = False Then
      If MsgBox("Un fichier portant ce nom existe déjà, voulez-vous le remplacer", vbYesNo) = vbNo Then GoTo annule
    End If
    On Error GoTo errSuppr
    Kill cheminPDF
    On Error GoTo err
  End If

  Set objWord = CreateObject("Word.Application")
  objWord.Visible = True
  Set objWordDoc = objWord.Documents.Open(cheminWord)
  If Not objWord Is Nothing Then
     objWordDoc.ExportAsFixedFormat cheminPDF, wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportAllDocument
  End If

fin:
  On Error Resume Next
  objWordDoc.Close False
  objWord.Quit
  Set objWordDoc = Nothing
  Set objWord = Nothing
  Exit Sub
err:
  MsgBox "Erreur: " & err.Description
  GoTo fin
errSource:
  MsgBox "Erreur: Fichier Word (.doc / .docx) introuvable"
  GoTo fin
errSuppr:
  MsgBox "Impossible de supprimer le fichier existant, il est peut-être ouvert?" & vbNewLine & "Opération annulée"
  GoTo fin
annule:
  MsgBox "Opération annulée"
  GoTo fin
errRepCible:
  MsgBox "Erreur: le répertoire cible n'existe pas, veuillez le créer ou prévenir un administrateur"
  GoTo fin
End Sub