Microsoft 365 macro imprimante

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
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
E

Eric KERGRESSE

XLDnaute Occasionnel
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
patricktoulon

patricktoulon

XLDnaute Barbatruc
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

Discussions similaires

M
  • Question
Autres Générer une étiquette pour imprimante thermique
Réponses
3
Affichages
203
fanch55
fanch55
Y
  • Résolu(e)
XL 2021 Macro pour imprimer un document
Réponses
2
Affichages
578
Yoan_VBA
Y
D
  • Question
XL 2010 Valoriser cellule par clic
Réponses
4
Affichages
221
fanch55
fanch55
T
  • Question
XL 2016 La macro efface les formules
Réponses
3
Affichages
239
JHA
J
K
  • Résolu(e)
XL 2010 VBA impression sous conditions
Réponses
2
Affichages
277
komarlehomard
K
C
  • Résolu(e)
XL 2021 Recherche et affichage de doublons
2
Réponses
26
Affichages
729
gbinforme
G
T
  • Question
XL 2019 Piloter Word depuis Excel pour créer un pdf
Réponses
1
Affichages
402
ThierryP
T
C
  • Résolu(e)
XL 2021 Macro dans Macro
2
Réponses
26
Affichages
378
Constantin
C
J
  • Résolu(e)
XL 2013 Changement port Ne pour imprimante sélectionner
2
Réponses
15
Affichages
1 K
Bernard_XLD
Bernard_XLD
3
  • Question
XL 2013 copier et coller un tableau croisé dynamique
Réponses
3
Affichages
145
306255
3

Membres actuellement en ligne

8 membres et 73 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 206
Messages
2 086 220
Membres
103 158
dernier inscrit
laufin