Microsoft 365 macro imprimante

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
P

pagoulet

XLDnaute Nouveau
Bonjour vous tous,

j'ai un blanc de mémoire.

J'ai créé une macro pour imprimer, tout fonctionne bien, mais elle ne revient pas à mon imprimante par défaut. Elle reste sur l'imprimante que j'ai sélection.

Est-ce que vous un exemple de code macro complet pour désigner d'imprimer sur une imprimante et de revenir sur l'imprimante par défaut ou le nom de l'imprimante qu'on veut qu'elle revienne.

Merci!
 
Trier par date Trier par votes
RE
@Eric KERGRESSE , @pagoulet
voila la version 2023 en fonction récursive
VB: 
'******************************************************************************************************************************************************
'    ___      _     _______  __      _    ____  _   _  _______  ___      _   _    _    ___      _     _.
'   //  \\   /\\      //    // \\   //   //    //  //    //    //  \\   //  //   //   //  \\   //|   //
'  //___//  //__\    //    //__//  //   //    //__||    //    //   //  //  //   //   //   //  // |  //
' //       //   \\  //    //  \\  //   //    //  \\    //    //   //  //  //   //   //   //  //  | //
'//       //    // //    //   // //   //___ //    \\  //     \\__//  //__//   //___ \\__//  //   |//
'******************************************************************************************************************************************************
'fonction pour lister les imprimantes pour excel
'patricktoulon sur vdeloppez.com
'date 16/12/2017
'mise à jour :10/12/2023
'api en 64
'mise a jour 10/12/2023
'on passe en mode récursifpour l'enumération

Option Explicit
'32bit'Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal HKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As LongPtr) As Long
'32bits'Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal HKey As Long, ByVal dwIndex As Long, ByVal lpPrinterName As String, lpcbPrinterName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As LongPtr, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As LongPtr, lpType As Long, lpData As Byte, lpcbData As Long) As Long
'32bits'Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As LongPtr) As Long
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"
Private Const KEY_QUERY_VALUE = &H1&
Private Const ERROR_NO_MORE_ITEMS = &H103
Private Const ERROR_MORE_DATA = &HEA
Sub testV2()
    Dim t, i&
    t = GetPrintersListV2
    MsgBox Join(t, vbCrLf)
End Sub

Public Function GetPrintersListV2(Optional IndexKey As Long = 0) As Variant
    Dim hKey As LongPtr, Res&, PrinterName$, DataType&, ValueValue() As Byte, i&, tx$, t$, a&, b&
    Static printers$(): Static indx As Long
    PrinterName = String$(256, Chr(0)): ReDim ValueValue(0 To 999): If IndexKey = 0 Then ReDim printers(1 To 1): indx = 0
    RegOpenKeyEx HKCU, PRINTER_KEY, 0&, KEY_QUERY_VALUE, hKey
    RegEnumValue hKey, IndexKey, PrinterName, Len(PrinterName), 0&, DataType, ValueValue(0), 1000: RegCloseKey hKey
    PrinterName = Split(PrinterName, Chr(0))(0)
    If Trim(PrinterName) <> "" Then
        t = StrConv(ValueValue, vbUnicode): a = InStr(1, t, ","): b = InStr(1, t, ":")
        tx = "": For i = a + 1 To b - 1: tx = tx & Mid(t, i, 1): Next:
        indx = indx + 1: ReDim Preserve printers(1 To indx): printers(indx) = PrinterName & " sur " & tx
        GetPrintersListV2 IndexKey + 1
    End If
    If IndexKey = 20 Then Exit Function    ' au pire des cas on sort  au bout de 20 essais
    GetPrintersListV2 = printers:
End Function
code compressé à mort 🤣 😉
j'ai bien galéré avec un vbnullchar qui me foutait le boxon @fanch55 a trouvé la bellugue dans le potage
elle est donc finalisée
 
Dernière édition:
Vote positif 0 Vote négatif
Ma version finale avec le code de Patrick :

VB: 
Sub TestImprimanteChoisie()

    ImprimanteChoisie ("HP8B643A")                ' Même avec un nom partiel de l'imprimante
    Debug.Print Application.ActivePrinter
   
    ' .... Suite du code
   
    ImprimanteChoisie ("Microsoft Print to PDF")  ' Mon imprimante par défaut
    Debug.Print Application.ActivePrinter

End Sub


Sub ImprimanteChoisie(ByVal NomImprimante As String)

Dim t, i&
   
    t = GetPrintersList
    For i = LBound(t) To UBound(t)
       If Not t(i) Like "*Nul*" And InStr(1, t(i), NomImprimante, vbTextCompare) > 0 Then 'Le nom de l'imprimante commence par
          Application.ActivePrinter = t(i)
          Exit For
       End If
    Next i
 
End Sub

Patrick, teste la procédure ImprimanteChoisie avec GetPrintersListV2.
 
Vote positif 0 Vote négatif
oupss j'enlevais le doublepoint dans le nom
voila tout testé c'est ok
VB: 
'******************************************************************************************************************************************************
'    ___      _     _______  __      _    ____  _   _  _______  ___      _   _    _    ___      _     _.
'   //  \\   /\\      //    // \\   //   //    //  //    //    //  \\   //  //   //   //  \\   //|   //
'  //___//  //__\    //    //__//  //   //    //__||    //    //   //  //  //   //   //   //  // |  //
' //       //   \\  //    //  \\  //   //    //  \\    //    //   //  //  //   //   //   //  //  | //
'//       //    // //    //   // //   //___ //    \\  //     \\__//  //__//   //___ \\__//  //   |//
'******************************************************************************************************************************************************
'fonction pour lister les imprimantes pour excel
'patricktoulon sur devellopez.com
'date 16/12/2017
'Version 1.0
'mise à jour :10/12/2023 sur Exceldownloads
'api en 64
'mise a jour 10/12/2023s ur Exceldownloads
'on passe en mode récursifpour l'enumération
'version 2.0
'*****************************************************************************************************************
Option Explicit
'32bit'Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal HKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As LongPtr) As Long
'32bits'Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal HKey As Long, ByVal dwIndex As Long, ByVal lpPrinterName As String, lpcbPrinterName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As LongPtr, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As LongPtr, lpType As Long, lpData As Byte, lpcbData As Long) As Long
'32bits'Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As LongPtr) As Long
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"
Private Const KEY_QUERY_VALUE = &H1&
Private Const ERROR_NO_MORE_ITEMS = &H103
Private Const ERROR_MORE_DATA = &HEA

Public Function GetPrintersListV2(Optional IndexKey As Long = 0) As Variant
    Dim hKey As LongPtr, Res&, PrinterName$, DataType&, ValueValue() As Byte, i&, tx$, t$, a&, b&
    Static printers$(): Static indx As Long
    PrinterName = String$(256, Chr(0)): ReDim ValueValue(0 To 999): If IndexKey = 0 Then ReDim printers(1 To 1): indx = 0
    RegOpenKeyEx HKCU, PRINTER_KEY, 0&, KEY_QUERY_VALUE, hKey
    RegEnumValue hKey, IndexKey, PrinterName, Len(PrinterName), 0&, DataType, ValueValue(0), 1000: RegCloseKey hKey
    PrinterName = Split(PrinterName, Chr(0))(0)
    If Trim(PrinterName) <> "" Then
        t = StrConv(ValueValue, vbUnicode): a = InStr(1, t, ","): b = InStr(1, t, ":")
        tx = "": For i = a + 1 To b: tx = tx & Mid(t, i, 1): Next:
        indx = indx + 1: ReDim Preserve printers(1 To indx): printers(indx) = PrinterName & " sur " & tx
        Debug.Print PrinterName & " sur " & tx
        GetPrintersListV2 IndexKey + 1
    End If
    If IndexKey = 20 Then Exit Function    ' au pire des cas on sort  au bout de 20 essais
    GetPrintersListV2 = printers:
End Function


Sub test3()
    Dim t, i&
    t = GetPrintersListV2
   ' MsgBox Join(t, vbCrLf)
    For i = LBound(t) To UBound(t)
       If Not t(i) Like "*nul*" Then Application.ActivePrinter = t(i)
       MsgBox Application.ActivePrinter
    Next i
    
End Sub


Sub TestImprimanteChoisie()

    ImprimanteChoisie ("HP8B643A")                ' Même avec un nom partiel de l'imprimante
    Debug.Print Application.ActivePrinter
  
    ' .... Suite du code
  
    ImprimanteChoisie ("Microsoft Print to PDF")  ' Mon imprimante par défaut
    Debug.Print Application.ActivePrinter

End Sub


Sub ImprimanteChoisie(ByVal NomImprimante As String)

Dim t, i&
  
    t = GetPrintersList
    For i = LBound(t) To UBound(t)
       If Not t(i) Like "*Nul*" And InStr(1, t(i), NomImprimante, vbTextCompare) > 0 Then 'Le nom de l'imprimante commence par
          Application.ActivePrinter = t(i)
          Exit For
       End If
    Next i
 
End Sub
 
Vote positif 1 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

N
  • Question Question
Microsoft 365 Choisir une imprimante pour imprimer doc word sous VBA Excel
Réponses
2
Affichages
167
natof
N
Agecanonix35400
  • Question Question
XL 2016 *** RESOLU MERCI :)*** Impression personnalisée.
2 3
Réponses
35
Affichages
502
TooFatBoy
TooFatBoy
K
  • Question Question
Microsoft 365 Planification avec variables d'ajustement
Réponses
8
Affichages
81
Kristelle1555
K
M
  • Question Question
Autres Générer une étiquette pour imprimante thermique
Réponses
3
Affichages
594
fanch55
fanch55
N
  • Résolu(e)
Microsoft 365 Macro enregistrement automatique pdf
2
Réponses
18
Affichages
687
Nounours4173
N
D
  • Question Question
XL 2021 Activation macro
Réponses
1
Affichages
59
sylvanu
sylvanu
D
  • Question Question
XL 2021 Problème de macro
Réponses
5
Affichages
69
Didierpasdoué
D
micheldu52
  • Question Question
Microsoft 365 Publipostage WORD
Réponses
2
Affichages
914
vgendron
vgendron
M
  • Résolu(e)
Microsoft 365 Erreur 9 macro
Réponses
3
Affichages
223
matmac
M
Y
  • Résolu(e)
XL 2013 Bloquer la saisie dans une plage selon un critère
Réponses
6
Affichages
466
TooFatBoy
TooFatBoy
M
  • Question Question
Microsoft 365 Automatisation de la date et des lignes sur Feuil1
Réponses
5
Affichages
618
Musbek
M
M
  • Résolu(e)
Microsoft 365 [RESOLU]UserForm qui revient à la fermeture d'un classeur, du fait le classeur se bloque et il faut fermer manuellement l'UserForm
2
Réponses
17
Affichages
519
Marboi
M
Y
  • Résolu(e)
XL 2021 Macro pour imprimer un document
Réponses
2
Affichages
942
Yoan_VBA
Y
D
  • Résolu(e)
XL 2019 Boucle sur plusieurs feuilles
Réponses
6
Affichages
502
dadaze
D
Jiheme
  • Question Question
XL 2019 Macro bloque en court de travail
Réponses
4
Affichages
255
fanch55
fanch55
D
  • Résolu(e)
Microsoft 365 VBA Déplacement de la cellule active dans une ligne sélectionnée
Réponses
11
Affichages
311
danielco
D
C
  • Résolu(e)
XL 2021 Userform impression + choix des feuilles
Réponses
8
Affichages
489
candido57
C
F
  • Question Question
Microsoft 365 macro-formule pour recopier une ligne automatiquement à chaque changement de nom
Réponses
5
Affichages
131
Cousinhub
Cousinhub
F
  • Question Question
Microsoft 365 Vba : copier certaines cellules suivant la valeur d'une autre
Réponses
2
Affichages
218
mapomme
mapomme
P
  • Résolu(e)
Microsoft 365 Utiliser la même macro dans des feuilles différentes
2 3
Réponses
35
Affichages
932
cathodique
cathodique
Retour