PDF archivé et à Imprimer plusieurs PDF entre 2 dates

Bonjour à tous,

Je viens vers vous pour ajouter un bout de code au code développé par BSALV que je remercie encore une fois!

ici c'était l'envois des PDF par mail des rapports entre 2 dates mais je souhaiterai qu'on ajoute aussi l'impression entre 2 dates par selection des rapports.

Ou bien pour choisir les PDF entre 2 dates qui se trouve dossier archive "C:\Users\ThibetStavaux\Desktop\archive" et imprimer ceux qui son sélectionnés.

Je vous remercie d'avance. Thibet

'Const Chemin = "C:\Users\ThibetStavaux\Desktop\archive"  'chemin Thibet
Const Chemin = "c:\users\eigenaar\downloads"    'chemin BSALV
Const NomFichier = "Bilan&rapport*.pdf"   '!!!! AVEC CE ABC, VOUS AUREZ UN MSGBOX COMME RESULTAT

Sub MesFichiers()
  Sheets("blad1").ListBox1.Clear
  Filename = Dir(Chemin & "\" & NomFichier)     'filtre sur le chemin et nom des fichiers

  Do While Filename <> ""     'boucle jusqu'à ce que tous ces fichiers sont traités
    sp = Split(Replace(Filename, ".", " "))   'divisé à l'espace
    If UBound(sp) >= 1 Then     'filename consiste de min 2 parties
      If sp(1) Like "##-##-####" Then     '2ième partie est une date de ce format
        sp1 = Split(sp(1), "-")
        madate = DateSerial(sp1(2), sp1(1), sp1(0))
        If (Range("Limite_Inférieure").Value < madate Or Range("Limite_Inférieure").Value = "") And (madate <= Range("Limite_Supérieure").Value Or Range("Limite_Supérieure").Value = "") Then
          s = s & vbLf & Filename     'string avec tous les fichiers avec une date dans cette période limitée
        Else
          s1 = s1 & vbLf & Filename     'string avec tous les fichiers avec une date dehors cette période limitée
        End If
      End If
    End If
    Filename = Dir()     'le suivant ...
  Loop

  If Len(s) = 0 Then     'rien trouvé !!!
    If Len(s1) > 0 Then s = s1: GoTo 1     'Y-a-t-il des fichier "Bilan.." dehors la période ???
    Filename = Dir(Chemin & "\*.pdf")     '2ième essai, tous les fichiers PDF dans ce chemin
    Do While Filename <> "" And ptr < 5     'montre les 5 premiers
      ptr = ptr + 1
      s = s & vbLf & Filename
      Filename = Dir()
    Loop

    If Len(s) = 0 Then     'encore rien trouvé !!!
      Filename = Dir(Chemin & "\*")     '3ième essai : tous les fichiers n'importe leur extension
      Do While Filename <> "" And ptr < 5     'montre les 5 premiers
        ptr = ptr + 1
        s = s & vbLf & Filename
        Filename = Dir()
      Loop
    End If
1:
    MsgBox "chemin = " & Chemin & vbLf & "premier 5 fichiers " & vbLf & s, vbInformation, UCase("il n'y a pas des fichiers dans cette période")     'fichiers pdf ou outre dans ce chemin
    Exit Sub
  End If

  If Len(s1) > 0 Then MsgBox s1, vbInformation, "hors période limitée"     'fichier "Bilan&Rapport ... dehors période"

  With Range("TBL_Autres").ListObject
    For i = 1 To .ListRows.Count
      s2 = .DataBodyRange.Cells(i, 1)
      If Len(s2) > 0 Then
        s = s & vbLf & s2
      End If
    Next
  End With

  sn = Split(Mid(s, 2), vbLf)

  With Sheets("blad1").ListBox1
    .List = sn
    .Height = Application.Min((2 + UBound(sn)) * 15, 450)     'hauteur du listbox en relation avec le nombre de lignes
  End With
End Sub

Sub Choisi()
  Dim MyOutlook As Object, MyMail As Object, LO

  With Sheets("blad1").ListBox1
    For i = 0 To .ListCount - 1
      If .Selected(i) = True Then
        s = s & vbLf & .List(i)
      End If
    Next
    If Len(s) = 0 Then MsgBox "aucun fichier est choisi"     ': Exit Sub
  End With

  Set MyOutlook = CreateObject("Outlook.Application")
  With MyOutlook.CreateItem(olMailItem)
    .To = Range("E3").Value
    .Subject = "En annexe les PDF demandés"
    .Body = "Suite à votre demande, je vous envoie ...." & IIf(Len(s) = 0, UCase("sans attachments"), "")
    If Len(s) > 0 Then
      sn = Split(Mid(s, 2), vbLf)
      For i = 0 To UBound(sn)
        b = (InStr(1, sn(i), "\", 1) > 0)     'le chemin est dans la cellule
        s = IIf(b, "", Chemin & "\") & sn(i)
        If Dir(s) <> "" Then
          .Attachments.Add s
        Else
          MsgBox "Fichier inntrouvable", vbInformation, sn(i)
        End If
      Next
    End If

    .display     'seulement montrer le mail
    '.send     'envoyer effectivement
  End With

End Sub

Edit modo : code indenté correctement

A+

bonjour,

communication n'est pas pas ma specialité, donc je ne comprends pas pourquoi ceci ne fonctionne pas.

le "Createobject ... " devait faire le job (imprimer un fichier sans l'ouvrir) ... (32 vs 64 bits ???), il n'y a pas d'erreur, mais il ne se passe rien.

Sub Choisi()
     Dim MyOutlook As Object, MyMail As Object, LO

     With Sheets("blad1").ListBox1
          For i = 0 To .ListCount - 1
               If .Selected(i) = True Then
                    s = s & vbLf & .List(i)
                    CreateObject("Shell.Application").Namespace(0).ParseName(Chemin & "\" & .List(i)).InvokeVerb ("Print")
               End If
          Next
          If Len(s) = 0 Then MsgBox "aucun fichier est choisi"     ': Exit Sub
     End With 
      .....

Bonjour BsAlv,

Non non pas du tout ça fonctionne parfaitement.

Ma demande à moi c'est uniquement d'imprimer plusieurs fichiers sélectionnés entre 2 dates.

J'ai crée un nouveau module pour imprimer mais recoit message suivant :

Merci d'avance

Bonjour BsAlv,

L'erreur venait du nom de mes fichiers dans mon archive il y avait une espace de trop. Maintenant les fichiers sont je sélectionne mais il n'envois pas vers imprimante
les fichiers sont bien sélectionnés mais il y a rien dans l'imprimante càd quand je clic sur PRINT rien se passe.

PS : Envois de mail avec les fichiers sélectionnés pas de soucis.

Merci

A+

donc à midi il a imprimé un fichier ?

Bonjour BsAlv,

Non il n'a pas du tout imprimé mais en ce qui concerne pour les envoyer ça fonctionne. Est-ce que dois-je faire qqch de spéciale dans Excel, mon imprimante HP2510 est bien configuré et je sais imprimer un tableau via Excel ou un document via Word sans problème.

Merci

A+

je ne sais pas vous aider, je ne connais pas assez de cette matière.

Bonsoir BsAlv,

Merci pour ton aide.

Peut-être que je me suis mal bien exprimé je souhaite tout simplement imprimer les fichiers sélectionnés étant donné les envois des factures sélectionnées fonctionne on devrait pouvoir les imprimer.

Ici un simple exemple d' impression d'une feuille : (ActiveSheet.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False, Preview:=True)

Un code qui pourra imprimer les fichiers sélectionnés.

Je ne sais pas mais est-ce que on peu écrire ou l'adapter ( J'ai trouvé un fichier peut-être qui pourra nous aider source : https://excel-downloads.com/threads/imprimer-tous-les-element-qui-se-trouve-dans-une-listbox.6673/)

' Boucle d'impression
Do While COMPTEUR_IMPRESSION < NB_COPIES
    With ListBox1
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then Workbooks(NOM_FICHIER2).Sheets(.List(i)).PrintOut       ' Impression des onglets que l'opérateur a sélectionnés
        Next
    End With
    COMPTEUR_IMPRESSION = COMPTEUR_IMPRESSION + 1
Loop

ou bien un autre code qui ressemble un peu à la notre (via google)

ub Bouton35_Clic()

Chemin = "C:\Documents and Settings\GVF08F3\Bureau\Nouveau dossier"
PDFFile = Sheets("Fiche à transmettre a CE").Select & ".pdf"

Sheets("Fiche à transmettre a CE").ExportAsFixedFormat Type:=x1TypePDF, _
Filename:=[M4] & [U3] & [L15] & [L16].Value, _
Quality:=x1QualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Dim Repertoire As FileDialog

Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Repertoire.Show

' Si aucun répertoire sélectionné
If Repertoire.SelectedItems().Count = 0 Then Exit Sub
' Récupérer le chemin sélectionné
Chemin = Repertoire.SelectedItems(1)
If Mid(Chemin, Len(Chemin), 1) <> "\" Then Chemin = Chemin & "\"

End Sub

Merci d'avance

A+

Adobe Reader doit être votre PDF favorite pour ouvrir vos pdf-files. https://www.pcastuces.com/pratique/astuces/4599.htm#:~:text=Ouvrez%20l%27explorateur%20et%20trouvez,application%20pour%20ouvrir%20les%20fichiers%20.

Une fois que cela est réglé vous pouvez imprimer avec CreateObject("Shell.Application").Namespace(0).ParseName(Chemin & "\" & .List(i)).InvokeVerb ("Print")

Bonsoir BsAlv,

Super! ça fonctionne il imprime directement.

Pourrions insérer un view avant impression "Preview:=True" dans le code est-ce que c'est possible ?

Merci

A+

Bonsoir

Juste comme ça un sujet donné par 3GB qui pourrait être intéressant concernant l'imprimante
https://forum.excel-pratique.com/s/goto/966457

Bonne soirée

Sub test()
     myfile = Dir(ThisWorkbook.Path & "\451*.pdf")     'tous les PDF-fichiers qui commencent avec 451  = un test à mon côté
     Do While myfile <> "" And i < 10     'les 10 premiers
          CreateObject("Shell.Application").Open ThisWorkbook.Path & "\" & myfile     'ouvrir sans imprimer
          CreateObject("Shell.Application").Namespace(0).ParseName(ThisWorkbook.Path & "\" & myfile).InvokeVerb ("Print")     'imprimer sans ouvrir
          i = i + 1
          myfile = Dir
     Loop
End Sub

Bonsoir BsAlv,

Donc j'ai 2 possibilités pour le bouton soit "ouvrir sans imprimer" ou bien "imprimer sans ouvrir" super !!! Mais comment pourrais-je adapté à mon code de myfile

au passage merci à BrunoM45

Const Chemin = "C:\Users\ThibetStavaux\Desktop\archive"  'chemin Thibet
'Const Chemin = "c:\users\eigenaar\downloads"    'chemin BSALV
Const NomFichier = "Bilan&rapport*.pdf"   '!!!! AVEC CE ABC, VOUS AUREZ UN MSGBOX COMME RESULTAT

Sub MesFichiers()
     Sheets("blad1").ListBox1.Clear
     FileName = Dir(Chemin & "\" & NomFichier)     'filtre sur le chemin et nom des fichiers

     Do While FileName <> ""     'boucle jusqu'à ce que tous ces fichiers sont traités
          sp = Split(Replace(FileName, ".", " "))   'divisé à l'espace
          If UBound(sp) >= 1 Then     'filename consiste de min 2 parties
               If sp(1) Like "##-##-####" Then     '2ième partie est une date de ce format
                    sp1 = Split(sp(1), "-")
                    madate = DateSerial(sp1(2), sp1(1), sp1(0))
                    If (Range("Limite_Inférieure").Value < madate Or Range("Limite_Inférieure").Value = "") And (madate <= Range("Limite_Supérieure").Value Or Range("Limite_Supérieure").Value = "") Then
                         s = s & vbLf & FileName     'string avec tous les fichiers avec une date dans cette période limitée
                    Else
                         s1 = s1 & vbLf & FileName     'string avec tous les fichiers avec une date dehors cette période limitée
                    End If
               End If
          End If
          FileName = Dir()     'le suivant ...
     Loop

     If Len(s) = 0 Then     'rien trouvé !!!
          If Len(s1) > 0 Then s = s1: GoTo 1     'Y-a-t-il des fichier "Bilan.." dehors la période ???
          FileName = Dir(Chemin & "\*.pdf")     '2ième essai, tous les fichiers PDF dans ce chemin
          Do While FileName <> "" And ptr < 5     'montre les 5 premiers
               ptr = ptr + 1
               s = s & vbLf & FileName
               FileName = Dir()
          Loop

          If Len(s) = 0 Then     'encore rien trouvé !!!
               FileName = Dir(Chemin & "\*")     '3ième essai : tous les fichiers n'importe leur extension
               Do While FileName <> "" And ptr < 5     'montre les 5 premiers
                    ptr = ptr + 1
                    s = s & vbLf & FileName
                    FileName = Dir()
               Loop
          End If
1:
          MsgBox "chemin = " & Chemin & vbLf & "premier 5 fichiers " & vbLf & s, vbInformation, UCase("il n'y a pas des fichiers dans cette période")     'fichiers pdf ou outre dans ce chemin
          Exit Sub
     End If

     If Len(s1) > 0 Then MsgBox s1, vbInformation, "hors période limitée"     'fichier "Bilan&Rapport ... dehors période"

     sn = Split(Mid(s, 2), vbLf)

     With Sheets("blad1").ListBox1
          .List = sn
          .Height = Application.Min((2 + UBound(sn)) * 15, 450)     'hauteur du listbox en relation avec le nombre de lignes
     End With
End Sub

Sub Choisi()
     Dim MyOutlook As Object, MyMail As Object

     With Sheets("blad1").ListBox1
          For i = 0 To .ListCount - 1
               If .Selected(i) = True Then
                    s = s & vbLf & .List(i)
               End If
          Next
          If Len(s) = 0 Then MsgBox "aucun fichier est choisi"     ': Exit Sub
     End With

     Set MyOutlook = CreateObject("Outlook.Application")
     With MyOutlook.CreateItem(olMailItem)
          .To = Range("E3").Value
          .Subject = "En annexe les PDF demandés"
          .Body = "Suite à votre demande, je vous envoie ...." & IIf(Len(s) = 0, UCase("sans attachments"), "")
          If Len(s) > 0 Then
               sn = Split(Mid(s, 2), vbLf)
               For i = 0 To UBound(sn)
                    .Attachments.Add Chemin & "\" & sn(i)
               Next
          End If
          .display     'seulement montrer le mail
          '.send     'envoyer effectivement
     End With

End Sub

Sub Choisi_p()

     Dim MyOutlook As Object, MyMail As Object, LO

     With Sheets("blad1").ListBox1
          For i = 0 To .ListCount - 1
               If .Selected(i) = True Then
                    s = s & vbLf & .List(i)
                    CreateObject("Shell.Application").Namespace(0).ParseName(Chemin & "\" & .List(i)).InvokeVerb ("Print")
               End If
          Next
          If Len(s) = 0 Then MsgBox "aucun fichier est choisi"     ': Exit Sub
     End With
End Sub

bonjour aussi BrunoM45, le fil,

la macro "Choisi_p" fonctionne, je suppose, je ne l'ai pas testé, l'autre à peu près le même ....

Sub Choisi()
     Dim MyOutlook As Object, MyMail As Object

     With Sheets("blad1").ListBox1
          For i = 0 To .ListCount - 1
               If .Selected(i) = True Then
                    CreateObject("Shell.Application").Open ThisWorkbook.Path & "\" & .list(i)     'ouvrir sans imprimer
                    s = s & vbLf & .List(i)
               End If
          Next
          If Len(s) = 0 Then MsgBox "aucun fichier est choisi"     ': Exit Sub
     End With 
     etc 

peut-être plus facile à maintenir, une macro paramétrée et 2 autres macros

Sub Choisi_Imprimer()
     Choisi False
End Sub

Sub Choisi_Ouvrir()
     Choisi True
End Sub

Sub Choisi(bOuvrir As Boolean)
     Dim MyOutlook As Object, MyMail As Object

     With Sheets("blad1").ListBox1
          For i = 0 To .ListCount - 1
               If .Selected(i) = True Then
                    If bOuvrir Then     'ouvrir sans imprimer ou imprimer sans ouvrir
                         CreateObject("Shell.Application").Open ThisWorkbook.Path & "\" & .list(i)     'ouvrir sans imprimer
                    Else
                         CreateObject("Shell.Application").Namespace(0).ParseName(ThisWorkbook.Path & "\" & .list(i)).InvokeVerb ("Print")     'imprimer sans ouvrir
                    End If
                    s = s & vbLf & .List(i)
               End If
          Next
          If Len(s) = 0 Then MsgBox "aucun fichier est choisi"     ': Exit Sub
     End With

     Set MyOutlook = CreateObject("Outlook.Application")
     With MyOutlook.CreateItem(olMailItem)
          .To = Range("E3").Value
          .Subject = "En annexe les PDF demandés"
          .Body = "Suite à votre demande, je vous envoie ...." & IIf(Len(s) = 0, UCase("sans attachments"), "")
          If Len(s) > 0 Then
               sn = Split(Mid(s, 2), vbLf)
               For i = 0 To UBound(sn)
                    .Attachments.Add Chemin & "\" & sn(i)
               Next
          End If
          .display     'seulement montrer le mail
     '.send     'envoyer effectivement
     End With

End Sub

Bonjour BsAlv,

J'ai une erreur qui revient, pourrais tu voir stp!!!

Fichier ci-dessous

Merci

A+

Bonjour à tous,

Est-ce que pourriez-vous m'aidez svp, où je fais l'erreur.

L'objectif est d'avoir le PrintPreview pour les fichiers PDF sélectionnés dans la listebox1, un affichage avant l'impression "Preview:=True" comme s'il s'ouvrait dans Adobe Reader.

Merci.

A+

Bonsoir Thibet

Merci de déposer votre fichier avec les dernières modifications SVP

A+

vous devez remplacer mon "Thisworkbook.path" par votre "Chemin" ou directement créer un nom sFile comme ceci

     For i = 0 To .ListCount - 1
          If .Selected(i) = True Then
               sFile = chemin & "\" & .List(i)
               MsgBox "pour vérifier le chemin et le nom : " & vbLf & sFile
               If bOuvrir Then     'ouvrir sans imprimer ou imprimer sans ouvrir
                    CreateObject("Shell.Application").Open sFile     'ouvrir sans imprimer
               Else
                    CreateObject("Shell.Application").Namespace(0).ParseName(sFile).InvokeVerb ("Print")     'imprimer sans ouvrir
               End If
               s = s & vbLf & .List(i)
          End If
     Next

vos fichiers PDF, il existent déjà un temps, VBA sait les ouvrir sans imprimer avec ce "CreateObject("Shell.Application").Open sFile".

Alors dans le window de Adobe, vous pouvez choisir un de ces fichiers ouverts et cela est votre "preview", mieux que ça n'est pas possible, je crains. A ce moment, vous pouvez decider à imprimer ce fichier.