Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

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

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
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

M
  • Question
Autres Générer une étiquette pour imprimante thermique
Réponses
3
Affichages
473
fanch55
  • Question
Microsoft 365 Publipostage WORD
Réponses
2
Affichages
788
vgendron
Y
  • Résolu(e)
XL 2021 Macro pour imprimer un document
Réponses
2
Affichages
813
Yoan_VBA
Y
C
  • Résolu(e)
XL 2021 Userform impression + choix des feuilles
Réponses
8
Affichages
263
candido57
C
E
  • Résolu(e)
Microsoft 365 Filtre sur LISTBOX
2
Réponses
16
Affichages
728
eric72
E
C
  • Résolu(e)
XL 2021 Macro pour mise en page
Réponses
11
Affichages
522
candido57
C
L
  • Question
Microsoft 365 Erreur "Excel a manqué de ressources..." avec macro
Réponses
3
Affichages
1 K
AtTheOne
  • Résolu(e)
Microsoft 365 VBA: ne travailler qu'avec les TABLES
Réponses
3
Affichages
184
merinos-BernardEtang
  • Question
Autres fenêtre "Publication"
Réponses
10
Affichages
426
ph.vanne
  • Résolu(e)
XL 2021 Exécuter une macro sur plusieurs feuilles
Réponses
9
Affichages
304
micie1509
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…