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

[Lauvia]

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]

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

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]

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

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é.

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]

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 :

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]

Merci,

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

Merci

 

[patricktoulon]

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

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]

avec un peu de netoyage de code ca donne ça

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]

Bonjour Patrick,

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

 

[patricktoulon]

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

 

[patricktoulon]

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

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

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