Erreur 1004 methode activeprinter

avec l'ajout de la ligne: Set WMIservice = GetObject("winmgmts:\\" & "." & "\root\cimv2") cela me renvoi bien mon imprimante réseau : "\\vms_whatdoc\Mes_impressionsPOC"

Donc ce code devrait fonctionner :

Sub imprimer_pdf(chemin_fichier As String, nom_fichier As String)
    Dim WMIservice As Object, imprimantes As Object, imprimante As Object
    Const imprimante_pdf As String = "Microsoft Print to PDF"
    Const imprimante_réseau As String = "\\vms_whatdoc\Mes_impressionsPOC"

    '// récupération imprimantes Windows
    Set WMIservice = GetObject("winmgmts:\\" & "." & "\root\cimv2")
    Set imprimantes = WMIservice.ExecQuery("Select * from Win32_Printer")

    '// impression via imprimante PDF

    'affectation imprimante PDF
    For Each imprimante In imprimantes
        If imprimante.Caption = imprimante_pdf Then imprimante.SetDefaultPrinter: Exit For
    Next imprimante

    'impression fichier
    CreateObject("Shell.Application").ShellExecute nom_fichier, , chemin_fichier, "print", 0

    '// restauration imprimante réseau
    restaurer_imprimante_réseau imprimante_réseau

End Sub

Sub restaurer_imprimante_réseau(nom_imprimante As String)
    Dim WMIservice As Object, imprimantes As Object, imprimante As Object

    Set WMIservice = GetObject("winmgmts:\\" & "." & "\root\cimv2")
    Set imprimantes = WMIservice.ExecQuery("Select * from Win32_Printer Where Local = FALSE")
    For Each imprimante In imprimantes
        If imprimante.Caption = nom_imprimante Then imprimante.SetDefaultPrinter: Exit For
    Next imprimante

End Sub

merci à vous mais hélas non

j'ai vraiment pensé que cela allait fonctionner mais:

conversion ok mais retour sur imprimante réseau non

Vérifier l'égalité en ajoutant une MsgBox :

Sub restaurer_imprimante_réseau(nom_imprimante As String)
    Dim WMIservice As Object, imprimantes As Object, imprimante As Object

    Set WMIservice = GetObject("winmgmts:\\" & "." & "\root\cimv2")
    Set imprimantes = WMIservice.ExecQuery("Select * from Win32_Printer Where Local = FALSE")
    For Each imprimante In imprimantes
        MsgBox  imprimante.Caption & " = " & nom_imprimante
        If imprimante.Caption = nom_imprimante Then imprimante.SetDefaultPrinter: Exit For
    Next imprimante

End Sub

voila ce que cela renvoi

Lol c'etait juste - au lieu de _ :)

à cette ligne

Const imprimante_réseau As String = "\\vms_whatdoc\Mes_impressionsPOC"

Soit

Const imprimante_réseau As String = "\\vms-whatdoc\Mes_impressionsPOC"

Votre macro fonctionne donc nickel merci !!!!

Darkangel,

Merci de ne pas oublier de clôturer ce fil SVP

A+

Bonjour Bruno
c’était deja fait mais j’ai recliqué au cas où.

Bonjour à vous tous

Je vous recontacte au sujet de ce post car j'ai change de pc et le code ne fonctionne plus

Sub imprimer_pdf(chemin_fichier As String, nom_fichier As String, dateen, ligne)
    Dim WMIservice As Object, imprimantes As Object, imprimante As Object
    Const imprimante_pdf As String = "Microsoft Print to PDF"
    Const imprimante_réseau As String = "\\vms-whatdoc\Mes_impressionsPOC"

    '// récupération imprimantes Windows
    Set WMIservice = GetObject("winmgmts:\\" & "." & "\root\cimv2")
    Set imprimantes = WMIservice.ExecQuery("Select * from Win32_Printer")

    '// impression via imprimante PDF

    'affectation imprimante PDF
    For Each imprimante In imprimantes
          If imprimante.Caption = imprimante_pdf Then imprimante.SetDefaultPrinter: Exit For
    Next imprimante

    'impression fichier
    CreateObject("Shell.Application").ShellExecute nom_fichier, , chemin_fichier, "print", 0

nomFicpdf = dateen & " - " & Worksheets("Ecriture").Range("F" & ligne) & ".pdf"
CheminDestPDF = ThisWorkbook.Path & "\Budget pieces\" & nomFicpdf

 Application.Wait (Now + TimeValue("0:00:02"))

    ' Use SendKeys to automate the save dialog
    SendKeys CheminDestPDF & "{ENTER}", True

    '// restauration imprimante réseau
    restaurer_imprimante_réseau imprimante_réseau

End Sub

Sub restaurer_imprimante_réseau(nom_imprimante As String)
    Dim WMIservice As Object, imprimantes As Object, imprimante As Object

    Set WMIservice = GetObject("winmgmts:\\" & "." & "\root\cimv2")
    Set imprimantes = WMIservice.ExecQuery("Select * from Win32_Printer Where Local = FALSE")
    For Each imprimante In imprimantes
    ' MsgBox imprimante.Caption & " = " & nom_imprimante
        If imprimante.Caption = nom_imprimante Then imprimante.SetDefaultPrinter: Exit For
    Next imprimante

End Sub

Avant tout fonctionnait bien et le fichier converti en pdf avec le bon nom

mais désormais je bute sur une nouvelle fenêtre:

on voit que l'image que j'ai sélectionné apparait bien mais que déjà l'imprimante n'est pas la bonne

pourtant quand je tente un msgbox je trouve bien Microsoft Print to PDF

  For Each imprimante In imprimantes
          If imprimante.Caption = imprimante_pdf Then imprimante.SetDefaultPrinter: Exit For
    Next imprimante

bien présent sur l'ordi

une idée de comment je pourrais procéder ou bypasser cette fenêtre?

Personne?

Bonsoir,

Le souci est que l'imprimante par défaut n'est pas reconnue avant la fin de la procédure. Il faut donc la terminer et lancer une nouvelle procédure. Comme suit :

Sub imprimer_image(chemin_fichier As String, nom_fichier As String, dateen, ligne)
    Dim WMIservice As Object, imprimantes As Object, imprimante As Object
    Const imprimante_pdf As String = "Microsoft Print to PDF"

    '// récupération imprimantes Windows
    Set WMIservice = GetObject("winmgmts:\\" & "." & "\root\cimv2")
    Set imprimantes = WMIservice.ExecQuery("Select * from Win32_Printer")

    '// impression via imprimante PDF

    'affectation imprimante PDF
    For Each imprimante In imprimantes
          If imprimante.Caption = imprimante_pdf Then imprimante.SetDefaultPrinter: Exit For
    Next imprimante

    'impression fichier PDF
    Application.OnTime Now + TimeValue("00:00:01"), "'imprimer_pdf " & Chr(34) & chemin_fichier & Chr(34) & ", " & Chr(34) & nom_fichier & Chr(34) & ", " & Chr(34) & dateen & Chr(34) & ", " & Chr(34) & ligne & "'"

End Sub

Sub imprimer_pdf(chemin_fichier As String, nom_fichier As String, dateen, ligne)
    Const imprimante_réseau As String = "\\vms-whatdoc\Mes_impressionsPOC"

    'impression fichier
    CreateObject("Shell.Application").ShellExecute nom_fichier, , chemin_fichier, "print", 0

    nomFicpdf = dateen & " - " & Worksheets("Ecriture").Range("F" & ligne) & ".pdf"
    CheminDestPDF = ThisWorkbook.Path & "\Budget pieces\" & nomFicpdf

    Application.Wait (Now + TimeValue("0:00:02"))

    ' Use SendKeys to automate the save dialog
    SendKeys CheminDestPDF & "{ENTER}", True

    '// restauration imprimante réseau
    restaurer_imprimante_réseau imprimante_réseau

End Sub

Sub restaurer_imprimante_réseau(nom_imprimante As String)
    Dim WMIservice As Object, imprimantes As Object, imprimante As Object

    Set WMIservice = GetObject("winmgmts:\\" & "." & "\root\cimv2")
    Set imprimantes = WMIservice.ExecQuery("Select * from Win32_Printer Where Local = FALSE")
    For Each imprimante In imprimantes
    ' MsgBox imprimante.Caption & " = " & nom_imprimante
        If imprimante.Caption = nom_imprimante Then imprimante.SetDefaultPrinter: Exit For
    Next imprimante

End Sub

Bonsoir,

Par ailleurs, vous avez une solution beaucoup plus simple pour imprimer une image en PDF sans passer par le changement de l'imprimante par défaut de Windows.

Sub imprimer_pdf(chemin_fichier As String, nom_fichier As String, dateen, ligne)
    Dim nom_image As String
    Const imprimante_pdf As String = "Microsoft Print to PDF"

    '// impression via imprimante PDF
    nom_image = chemin_fichier & "\" & nom_fichier
    CreateObject("Shell.Application").ShellExecute "rundll32.exe", "C:\WINDOWS\System32\shimgvw.dll,ImageView_PrintTo /pt " & Chr(34) & nom_image & Chr(34) & " " & Chr(34) & imprimante_pdf & Chr(34), "", "open", 1

    nomFicpdf = dateen & " - " & Worksheets("Ecriture").Range("F" & ligne) & ".pdf"
    CheminDestPDF = ThisWorkbook.Path & "\Budget pieces\" & nomFicpdf

    Application.Wait (Now + TimeValue("0:00:02"))

    ' Use SendKeys to automate the save dialog
    SendKeys CheminDestPDF & "{ENTER}", True

End Sub

Bonjour Thev et merci pour votre retour

toutefois aucune des deux propositions ne semble fonctionner

Du reste dans le cadre la version simplifiée ce qui serait idéal l'image n'est pas du tout convertie

Je vais donc tenter d'expliquer un peu plus les choses

dans mon fichier chaque nouvelle ligne possède un bouton upload qui permet de sélectionner l'image à convertir en pdf dont voici le code

Sub Upload_Click()
Dim myfile As String
Dim oFSO As Object
Dim Sh As Shape
Dim CheminDest As String
Dim nomFic As String
Dim FichPDF As String

Set Sh = ActiveSheet.Shapes(Application.Caller) 'recupere le bouton cliqué

Dim ligne As Long
Dim colonne As Long

ligne = Sh.TopLeftCell.Row          'N° ligne du bouton
colonne = Sh.TopLeftCell.Column 'N° colonne du bouton

If MsgBox("Confirmation Ligne: " & ligne, vbYesNo, "Demande de confirmation") = vbYes Then

If (Worksheets("Ecriture").Range("F" & ligne) = "") Then Exit Sub

 datefr = Worksheets("Ecriture").Range("A" & ligne)
 dateen = Format(datefr, "yyyy-mm-dd")
nomFic = dateen & " - " & Worksheets("Ecriture").Range("F" & ligne) & ".jpg"
CheminDest = ThisWorkbook.Path & "\Budget pieces\" & nomFic

nomFic2 = dateen & " - " & Worksheets("Ecriture").Range("F" & ligne) & ".pdf"

Set oFSO = CreateObject("Scripting.FileSystemObject")
myfile = Application.GetOpenFilename(, , "Browse for Files")

If myfile <> "" Then

nam = Right(myfile, DernierePosition(myfile, ".") - 1)

If (nam <> "pdf") Then
'TextToDisplay:=dateen & " - " & Worksheets("Ecriture").Range("F" & ligne)
oFSO.CopyFile myfile, CheminDest, True
With Worksheets("Ecriture")
 .Hyperlinks.Add Anchor:=.Range("K" & ligne), _
 Address:="Budget%20pieces\" & nomFic2, _
TextToDisplay:="" & Worksheets("Ecriture").Range("F" & ligne)
End With
Worksheets("Ecriture").Range("K" & ligne).Font.Size = 9
Sh.Select
Sh.Delete

FichPDF = Split(CheminDest, ".")(0) & ".pdf"
  ChDir ThisWorkbook.Path & "\Budget pieces\"
Call imprimer_pdf(ThisWorkbook.Path & "\Budget pieces", CheminDest, dateen, ligne)

Else
dest = ThisWorkbook.Path & "\Budget pieces\" & nomFic2
oFSO.CopyFile myfile, dest, True
With Worksheets("Ecriture")
 .Hyperlinks.Add Anchor:=.Range("K" & ligne), _
 Address:="Budget%20pieces\" & nomFic2, _
 TextToDisplay:="" & Worksheets("Ecriture").Range("F" & ligne)
 ' TextToDisplay:=dateen & " - " & Worksheets("Ecriture").Range("F" & ligne)
End With
Worksheets("Ecriture").Range("K" & ligne).Font.Size = 9
Sh.Select
Sh.Delete
End If

End If
If Application.Wait(Now + TimeValue("0:00:04")) Then
  Kill myfile
End If

If (nam = "jpg") Then
If Application.Wait(Now + TimeValue("0:00:4")) Then
 Kill ThisWorkbook.Path & "\Budget pieces\" & dateen & " - " & Worksheets("Ecriture").Range("F" & ligne) & ".jpg"
End If
 End If
 End If

End Sub

cela lançait ensuite la macro imprimer_pdf qui avant fonctionnait si cas d'une image et non d'un pdf

si je tente de rajouter votre macro simplifié l'image est bien mise dans le dossier de destination mais rien ne se passe et le format reste en jpg ici

Bonjour,

Je ne sais pas où est votre problème mais le code ci-dessous fonctionne chez moi sans problème pour une image :

Sub imprimer_pdf(chemin_fichier As String, nom_fichier As String, dateen, ligne)
    Dim nom_image As String
    Const imprimante_pdf As String = "Microsoft Print to PDF"

    '// impression via imprimante PDF
    nom_image = chemin_fichier & "\" & nom_fichier
    CreateObject("Shell.Application").ShellExecute "rundll32.exe", "C:\WINDOWS\System32\shimgvw.dll,ImageView_PrintTo /pt " & Chr(34) & nom_image & Chr(34) & " " & Chr(34) & imprimante_pdf & Chr(34), "", "open", 1
    nomFicpdf = dateen & " - " & Worksheets("Ecriture").Range("F" & ligne) & ".pdf"
    CheminDestPDF = ThisWorkbook.Path & "\Budget pieces\" & nomFicpdf

    ' Use SendKeys to automate the save dialog
    Application.Wait (Now + TimeValue("0:00:01"))
    SendKeys CheminDestPDF, True
    Application.Wait (Now + TimeValue("0:00:01"))
    SendKeys "{ENTER}", True

End Sub

Bonjour,

Effectivement, merci à vous, j'ai du trouver la faille mais parfaitement fonctionnel :) nom_image etant nom_fichier dans mon cas !

Fonctionne nickel!!

Bonjour,

sans vouloir abuser @thev serait il possible d'ajouter un code permettant de ne pas ajuster et surtout mettre dans le bon sens (à l'heure actuelle quand converti mis sur le coté)?

merci par avance

@thev

Bonjour, je me permet de vous relancer au sujet du topic ci dessus.

merci par avance

Bonjour à tous

je crois qu'il y a confusion

ne pas confondre

1. activeprinter qui est l'imprimante active engagée dans excel
2. et l'imprimante sélectionnée dans le gestionnaire d'imprimante dans Windows

Concrètement ça veut dire quoi : et bien que la gestion d'impression hors contexte excel( en l'occurrence ici un fichier jpg)

va devoir se faire extérieurement mais!!! on a la possibilité de piloter l'impression externe par vba

exemple ici l'image va être imprimée avec l'imprimante selectionnée de Windows

Sub test()
 Dim Fichier$
 Fichier = "H:\Espace fond écran (6).jpg"
    ImprimerFichier Fichier
End Sub

'modele 2
Function ImprimerFichier(ByVal Fichier As String)
    By patricktoulon
CreateObject("Shell.Application").Namespace(0).ParseName(Fichier).InvokeVerb ("Print")
    'Application.Wait (Now + TimeValue("0:00:03"))
    'Shell "Taskkill /im AcroRd32.exe /f", 0    'changer "AcroRd32.exe" pour le nom de ton app qui ouvre tes pdf  pour tuer son processus
End Function

en l’occurrence j'ai dans mon Windows l'imprimante pdf de Microsoft qui est sélectionnée

maintenant a supposer que vous n'ayez pas l'imprimante windows pdf sélectionnée

là encore on peut changer l'imprimante dans les paramètre windows par vba

pour cela je vous renvoie a ma petite boite de dialogue perso ici:

https://excel-downloads.com/resources/collection-fausse-boite-de-dialogue-patricktoulon-episode-2-di...

et l'on voit bien que que l'on peut changer l'imprimante dans windows par vba

Bon d'accords c'est sur W 7 mais ça fonctionne toujours sur W10

les grands crack du forum n'auront aucun mal a repiquer du code de ma fausse boite de dialoque imprimante windows
et l'ajouter a la fonction d'impression dument citée un peu plus haut dans ma réponse

maintenant si ton intention est d'imprimer ton jpeg et de paramétrer sa taille dans une feuille A4(même en pdf)

il faudra alors jouer avec les zone d'impression , les hpagebreaks et vpagebreaks

et là encore placer l'image centrée dans la page

pour cela aussi tu trouvera ici une petite fonction toute simple ( dans le lien ci dessous ) qui consiste a placer une image au centre d'une plage le plus grand possible en respectant l'aspect ratio de l'image

https://excel-downloads.com/resources/centrer-une-image-dans-un-range-en-toute-circonstances-quel-qu...

si je vois que personne n'y arrive je reviendrais

Merci Patrick pour votre retour qu'il va me falloir approfondir et tester avant de revenir vers vous car là tout semble se compliquer

Toutefois mon code ci dessous fonctionnait parfaitement sur mon ancien pc et suite au changement de pc je bute juste sur la fenêtre windows dans laquelle je ne sais pas changer le nom de l'imprimante ni décocher adapter l'image ni choisir le format alors qu'avant rien à choisir ..

Sub imprimer_pdf(chemin_fichier As String, nom_fichier As String, dateen, ligne)
Dim WMIservice As Object, imprimantes As Object, imprimante As Object
Const imprimante_pdf As String = "Microsoft Print to PDF"
Const imprimante_réseau As String = "\\vms-whatdoc\Mes_impressionsPOC"

'// récupération imprimantes Windows
Set WMIservice = GetObject("winmgmts:\\" & "." & "\root\cimv2")
Set imprimantes = WMIservice.ExecQuery("Select * from Win32_Printer")

'// impression via imprimante PDF

'affectation imprimante PDF
For Each imprimante In imprimantes
If imprimante.Caption = imprimante_pdf Then imprimante.SetDefaultPrinter: Exit For
Next imprimante

'impression fichier
CreateObject("Shell.Application").ShellExecute nom_fichier, , chemin_fichier, "print", 0

nomFicpdf = dateen & " - " & Worksheets("Ecriture").Range("F" & ligne) & ".pdf"
CheminDestPDF = ThisWorkbook.Path & "\Budget pieces\" & nomFicpdf

Application.Wait (Now + TimeValue("0:00:02"))

' Use SendKeys to automate the save dialog
SendKeys CheminDestPDF & "{ENTER}", True

'// restauration imprimante réseau
restaurer_imprimante_réseau imprimante_réseau

End Sub

Sub restaurer_imprimante_réseau(nom_imprimante As String)
Dim WMIservice As Object, imprimantes As Object, imprimante As Object

Set WMIservice = GetObject("winmgmts:\\" & "." & "\root\cimv2")
Set imprimantes = WMIservice.ExecQuery("Select * from Win32_Printer Where Local = FALSE")
For Each imprimante In imprimantes
' MsgBox imprimante.Caption & " = " & nom_imprimante
If imprimante.Caption = nom_imprimante Then imprimante.SetDefaultPrinter: Exit For
Next imprimante

End Sub