Autres Sauvegarde d'une séléction en pdf (Excel 2007)

Lauvia · 12 Janvier 2021

Bonjour,

j'ai fait un Excel pour gérer un certain nombre de choses dont la sauvegarde de facture dans un dossier spécifique.
J'utilise PDFCreator pour l'écriture en pdf.
Mon fichier est bien sauvegargé à l'endroit exact mais malheureusement sans extension et du coup je ne peux pas ouvrir,
même pas en y accolant ".pdf" à la fin.
Quelqu'un a-t-il une idée du pourquoi de comment?

Merci pour toute réponse rapide.

Cordialement.

kiki29 · 12 Janvier 2021

re, comme cela tu crées un fichier PostScript( *.ps ), il faut ensuite le convertir en PDF.
Il te faut pour cela Acrobat ( pas le Reader ) voir un exemple ici
Bref tu t'embarques dans le genre : pourquoi faire simple quand on peut faire compliqué.
Normalement ceci devrait suffire :

VB:

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long

Option Explicit

Private Function CreationDossier(sDossier As String) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&...

kiki29 · 12 Janvier 2021

Salut, depuis Office 2007 SP2 la sauvegarde en PDF est intégré à Office
sinon adapter à ton contexte ceci :

Code:

Option Explicit

Private Function GetPrinterWithPort(ByVal sPrinterName As String) As String
Dim Reg As Variant, oReg As Object, myStr As Variant
Dim Ar() As Variant, regvalue As Variant
Const HKEY_CURRENT_USER = &H80000001
    Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    With oReg
        .enumvalues HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", myStr, Ar
        .getstringvalue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Reg, regvalue
        .getstringvalue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", sPrinterName, regvalue
    End With
    GetPrinterWithPort = sPrinterName & " sur " & Mid(regvalue, InStr(regvalue, ",") + 1)
End Function

Sub Test_PDFCreator_02()
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
                                         GetPrinterWithPort("PDFCreator"), Collate:=True
End Sub

Lauvia · 12 Janvier 2021

kiki29 à dit:

Salut, depuis Office 2007 SP2 la sauvegarde en PDF est intégré à Office
sinon adapter à ton contexte ceci :

Code:

Option Explicit

Private Function GetPrinterWithPort(ByVal sPrinterName As String) As String
Dim Reg As Variant, oReg As Object, myStr As Variant
Dim Ar() As Variant, regvalue As Variant
Const HKEY_CURRENT_USER = &H80000001
    Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    With oReg
        .enumvalues HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", myStr, Ar
        .getstringvalue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Reg, regvalue
        .getstringvalue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", sPrinterName, regvalue
    End With
    GetPrinterWithPort = sPrinterName & " sur " & Mid(regvalue, InStr(regvalue, ",") + 1)
End Function

Sub Test_PDFCreator_02()
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
                                         GetPrinterWithPort("PDFCreator"), Collate:=True
End Sub

Bonsoir Kiki,

et merci pour ton retour.
Ton script est un peu plus...professionnel . J'ai déjà pu obtenir ce résultat.
Mon soucis est plutôt dans l'utilisation automatique d'un nom généré par l'autre partie de mon tool, et surtout le chemin de sauvegarde spécifié.

Code:

Sub Test_PDFCreator_02(path As Variant)
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
    GetPrinterWithPort("PDFCreator"), PrintToFile:=True, Collate:=True, PrToFileName:=path
End Sub

avec path = chemin/nomFichier

C'est là où tout se gâte. il crée bien le fichier mais sans aucune extension (.pdf)

kiki29 · 12 Janvier 2021

re, comme cela tu crées un fichier PostScript( *.ps ), il faut ensuite le convertir en PDF.
Il te faut pour cela Acrobat ( pas le Reader ) voir un exemple ici
Bref tu t'embarques dans le genre : pourquoi faire simple quand on peut faire compliqué.
Normalement ceci devrait suffire :

VB:

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long

Option Explicit

Private Function CreationDossier(sDossier As String) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function

Sub Impression()
Dim sFichier As String
Dim sDossier As String

    sDossier = ThisWorkbook.Path & "\" & "Tests"
    CreationDossier sDossier

    sFichier = "Test.pdf"

    Feuil6.ExportAsFixedFormat Type:=xlTypePDF, _
                               Filename:=sDossier & "\" & sFichier, _
                               Quality:=xlQualityStandard, _
                               IncludeDocProperties:=True, _
                               IgnorePrintAreas:=False, _
                               From:=1, To:=1, _
                               OpenAfterPublish:=False
End Sub

Feuil6 est le CodeName de l'onglet "Facture", ceci permet de ne pas retoucher au code VBA si l'on renomme ou déplace l'onglet Facture.

Lauvia · 13 Janvier 2021

Merci,

j'ai effectué de petites modifs pour mettre le script entièrement à ma sauce et ça marche!

Merci

patricktoulon · 13 Janvier 2021

bonjour
si tu veux imprimer en pdf une plage c'est la selection qu'il faut exporter pas la feuille
pour le reste de ton code il est un peu a rallonge mais ca fonctionne

VB:

Sub Impression()
    Dim sFichier As String
    Dim sDossier As String
    Dim Fact As Variant, nomFichier As String

    Set Fact = Worksheets("Facture")
    nomFichier = Fact.Cells(14, 5).Value    'lire le nom du fichier depuis la feuille facture, cellule E14
    sDossier = ThisWorkbook.path & "\" & "Factures"   'chemin d'accès au dossier Factures

    sFichier = nomFichier & ".pdf"

    Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                                  sDossier & "\" & sFichier, Quality:=xlQualityStandard, _
                                  IncludeDocProperties:=True, IgnorePrintAreas:=False, From:=1, To:=1, _
                                  OpenAfterPublish:=False

End Sub

patricktoulon · 13 Janvier 2021

avec un peu de netoyage de code ca donne ça

VB:

Private Function CreationDossier(sDossier As String) As Long
    If Dir(sDossier, vbDirectory) = "" Then MkDir sDossier: MsgBox "le dossier a été créé"
End Function


Private Sub imprimer_Click(): ImpFacture: End Sub


Sub ImpFacture()
    Dim lgdeb, lgfin, cldeb, clfin As Integer
    Dim Msg, Style, Title, Help, Ctxt, Response, MyString
    Dim sDossier As String

    sDossier = ThisWorkbook.path & "\" & "Factures"   'chemin d'accès au dossier Factures

    CreationDossier (sDossier)   ' test d'existence du dossier 'Factures' et création le cas échéant

    Msg = "Voulez vous Imprimer la Facture?"
    Title = "Impression Document "    ' Définit le titre.
    Style = vbYesNo + vbExclamation + vbDefaultButton2    '+ vb    ' Définit les boutons.
    Response = MsgBox(Msg, Style, Title)

    If Response = vbYes Then    ' L'utilisateur a choisi Oui.
        lgdeb = 3    ' début ligne d'impression
        cldeb = 2    'début colonne d'impression
        lgfin = 55    ' fin ligne d'impression
        clfin = 12    ' fin colonne d'impression
        Sheets("Facture").Select
        Range(Cells(lgdeb, cldeb), Cells(lgfin, clfin)).Select    '(Cells(lgdeb, cldeb), Cells(lgfin, clfin)).Select

        Impression
    End If

    If Response = vbNo Then  'L'utilisateur a choisi "non" et sauvegarde la facture en PDF

    End If
End Sub


Sub Impression()
    Dim sFichier As String
    Dim sDossier As String
    Dim Fact As Variant, nomFichier As String

    Set Fact = Worksheets("Facture")
    nomFichier = Fact.Cells(14, 5).Value    'lire le nom du fichier depuis la feuille facture, cellule E14
    sDossier = ThisWorkbook.path & "\" & "Factures"   'chemin d'accès au dossier Factures

    sFichier = nomFichier & ".pdf"

    Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                                  sDossier & "\" & sFichier, Quality:=xlQualityStandard, _
                                  IncludeDocProperties:=True, IgnorePrintAreas:=False, From:=1, To:=1, _
                                  OpenAfterPublish:=False

End Sub

et on peu encore simplifier

Lauvia · 13 Janvier 2021

Bonjour Patrick,

Super, merci pour le toilettage du code.
Il marche super bien.
Merci

patricktoulon · 13 Janvier 2021

re
y a pas de quoi si tu veux je te fait plus propre encore

patricktoulon · 13 Janvier 2021

re et avec un gros netoyage ça donne ça
la sub impression est maintenant argumentée

VB:

Private Sub imprimer_Click(): ImpFacture: End Sub

Private Function GetDossier(sdossier As String) As String
    If Dir(sdossier, vbDirectory) = "" Then MkDir sdossier: MsgBox "le dossier a été créé"
        GetDossier = sdossier
End Function

Sub ImpFacture()
    Dim sdossier As String, rng As Range, feuille As Worksheet, nomPDF As String

    If MsgBox("Voulez vous Imprimer la Facture?", vbYesNo + vbExclamation + vbDefaultButton2, "Impression Document ") = vbYes Then

        sdossier = GetDossier(ThisWorkbook.path & "\" & "Factures")   ' teste l'existence du dossier 'Factures' et le créé si il n'existe pas
        Set feuille = Sheets("Facture")    'détermine la feuille(object worksheet)
        Set rng = feuille.Range(feuille.Cells(3, 2), feuille.Cells(55, 12))    'détermine la plage a imprimer en pdf
        nomPDF = feuille.Cells(14, 5).Value & ".pdf"    'détermine le nom du fichier
        ImpressionPDF feuille, rng, nomPDF, sdossier    'lance l'impression avec les parametres

    Else: MsgBox "impression annulée"    'si vbno msgbox d'annulation
    End If
End Sub


Sub ImpressionPDF(feuille As Worksheet, rng As Range, nomPDF As String, sdossier As String)
    feuille.Activate: rng.Select
    Selection.ExportAsFixedFormat Type:=xlTypePDF, _
                                  Filename:=sdossier & "\" & nomPDF, _
                                  Quality:=xlQualityStandard, _
                                  IncludeDocProperties:=True, _
                                  IgnorePrintAreas:=False, _
                                  From:=1, To:=1, _
                                  OpenAfterPublish:=False

    [A1].Select
End Sub

demain tu veux modifier quelque chose tu n'aura qu'a modifier ces lignes

VB:

sdossier = GetDossier(ThisWorkbook.path & "\" & "Factures")   ' teste l'existence du dossier 'Factures' et le créé si il n'existe pas
Set feuille = Sheets("Facture")    'détermine la feuille(object worksheet)
Set rng = feuille.Range(feuille.Cells(3, 2), feuille.Cells(55, 12))    'détermine la plage a imprimer en pdf
nomPDF = feuille.Cells(14, 5).Value & ".pdf"    'détermine le nom du fichier

Autres Sauvegarde d'une séléction en pdf (Excel 2007)

Lauvia

XLDnaute Nouveau

Pièces jointes

kiki29

kiki29

XLDnaute Barbatruc

Lauvia

XLDnaute Nouveau

kiki29

XLDnaute Barbatruc

Pièces jointes

Lauvia

XLDnaute Nouveau

Pièces jointes

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Lauvia

XLDnaute Nouveau

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Discussions similaires