Macro pour choix entre 2 fonctions imprimantes avec Excel

J'ai omis de mentionner que tu n'as qu'à utiliser la procédure : "Sub Imprimer_FeuilleActive()" à la fin du code.  MichD

Bonjour à vous deux,

Si je peux me permettre, essaie ceci :
À copier dans le même module.

Option Explicit
' ******  à adapter
Private Const NomImpr As String = "Canon MG5300 series Printer WS"
' D'après : http://www.vbfrance.com/codes/CHANGER-PROPRIETES-IMPRIMANTE-COURS_7485.aspx
Public Bacs() As String
Public Type PRINTER_DEFAULTS
   pDatatype As Long
   pDevMode As Long
   DesiredAccess As Long
End Type

Public Const HWND_BROADCAST = &HFFFF
Public Const WM_WININICHANGE = &H1A
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const PRINTER_ACCESS_ADMINISTER = &H4
Private Const PRINTER_ACCESS_USE = &H8
Private Const PRINTER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE)
Private Const PRINTER_ATTRIBUTE_DEFAULT = 4
Private Const DM_MODIFY = 8
Private Const DM_IN_BUFFER = DM_MODIFY
Private Const DM_COPY = 2
Private Const DM_OUT_BUFFER = DM_COPY
Private Const DMDUP_SIMPLEX = 1
Private Const DMDUP_VERTICAL = 2
Private Const DMDUP_HORIZONTAL = 3
Private Const DM_DUPLEX = &H1000&
Private Const DM_DEFAULTSOURCE = &H200
Private Const DM_ORIENTATION = &H1&
Private Const DM_PAPERLENGTH = &H4&
Private Const DM_PAPERSIZE = &H2&
Private Const DM_PAPERWIDTH = &H8&
Private Const DM_YRESOLUTION = &H2000&
Public Const DMORIENT_PORTRAIT = &H1&
Public Const DMORIENT_LANDSCAPE = &H2&
Public Const DMPAPER_A4 = 9                              '  A4 210 x 297 mm
Public Const DMPAPER_A5 = 11                            '  A5 148 x 210 mm
Public Const DMPAPER_ENV_C5 = 28                '  Envelope C5 162 x 229 mm
Public Const DMPAPER_ENV_DL = 27                '  Envelope DL 110 x 220mm
Private Const DC_BINNAMES = 12
Private Const DC_BINS = 6  ' pour les bacs
'Private Const DC_PAPERNAMES = 16        ' Value obtained from wingdi.h
'Private Const DC_STAPLE = 30
'Private Const DC_PRINTRATEPPM = 31
'Private Const DC_MEDIATYPENAMES = 34
'Private Const DC_MEDIATYPES = 35

Const PRINTER_ENUM_CONNECTIONS = &H4
Const PRINTER_ENUM_LOCAL = &H2
 Private Type DEVMODE
   dmDeviceName As String * CCHDEVICENAME
   dmSpecVersion As Integer
   dmDriverVersion As Integer
   dmSize As Integer
   dmDriverExtra As Integer
   dmFields As Long
   dmOrientation As Integer
   dmPaperSize As Integer
   dmPaperLength As Integer
   dmPaperWidth As Integer
   dmScale As Integer
   dmCopies As Integer
   dmDefaultSource As Integer
   dmPrintQuality As Integer
   dmColor As Integer
   dmDuplex As Integer
   dmYResolution As Integer
   dmTTOption As Integer
   dmCollate As Integer
   dmFormName As String * CCHFORMNAME
   dmLogPixels As Integer
   dmBitsPerPel As Long
   dmPelsWidth As Long
   dmPelsHeight As Long
   dmDisplayFlags As Long
   dmDisplayFrequency As Long
   dmICMMethod As Long        ' // Windows 9x seulement
   dmICMIntent As Long        ' // Windows 9x seulement
   dmMediaType As Long        ' // Windows 9x seulement
   dmDitherType As Long       ' // Windows 9x seulement
   dmReserved1 As Long        ' // Windows 9x seulement
   dmReserved2 As Long        ' // Windows 9x only
End Type

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Public Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
   Alias "DeviceCapabilitiesA" (ByVal lpsDeviceName As String, _
   ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
   ByVal dev As Long) As Long

Public Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, pDefault As PRINTER_DEFAULTS) As Long
Public Declare Function SetPrinter Lib "winspool.drv" Alias "SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Any, ByVal Command As Long) As Long
Public Declare Function GetPrinter Lib "winspool.drv" Alias "GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Any, ByVal cbBuf As Long, pcbNeeded As Long) As Long
Public Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Public Declare Function AbortDoc Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DocumentProperties Lib "winspool.drv" Alias "DocumentPropertiesA" (ByVal hwnd As Long, ByVal hPrinter As Long, ByVal pDeviceName As String, pDevModeOutput As Any, pDevModeInput As Any, ByVal fMode As Long) As Long

'-----------------------------------------------------------
Public Function ChangePrinterSettings(ByRef pOldBin As Integer, ByVal pNewBin As Integer) As Boolean
'****************************************************************
'* Gestion des imprimantes *
'*---------------------------------------------------------------------------- *
'* Modification : *
'*        - du format du papier *
'*  et/ou - de l'orientation *
'*  et/ou - du bac d'entrée *
'****************************************************************
    Dim hPrinter As Long          'Handle de printer
   Dim pd As PRINTER_DEFAULTS
   Dim ret As Long, i As Long
   Dim TabInfos() As Long
   Dim TabInfosSizeNeed As Long            ' Taille du tableau nécessaire
   Dim NewDevMode As DEVMODE
   Dim pFullDevMode As Long
   Dim LastError As Long
   Dim rep As Long
    On Error GoTo ChangePrinterSettingsError
    'Affecte les membres de PRINTER_DEFAULTS
   With pd
       .pDatatype = 0&
       .pDevMode = 0&
       .DesiredAccess = PRINTER_ALL_ACCESS
   End With
    'Fournit un hPrinter à Printer.DeviceName
   ret = OpenPrinter(NomImpr, hPrinter, pd)
    'Echec de l'ouverture de l'imprimante
   If ret = False Then
       'pb de droits sur l'imprimante : on rééssaye avec des droits de simple utilisateur (Win NT/2000/XP seulement)
       pd.DesiredAccess = (STANDARD_RIGHTS_REQUIRED Or PRINTER_ACCESS_USE)
       ret = OpenPrinter(NomImpr, hPrinter, pd)
       If ret = False Then
           Select Case GetLastError()
               Case 0 To 6
               Case 1722
                   MsgBox "Votre imprimante par défaut est hors connexion. Si c'est une imprimante réseau, vérifier que le poste qui y est rattaché est bien allumé", vbExclamation
                   Exit Function
               Case Else
                   MsgBox "Erreur de l'API OpenPrinter Code: " & GetLastError()
                   Exit Function
           End Select
       End If
   End If
    ret = GetPrinter(hPrinter, 2, ByVal 0&, 0, TabInfosSizeNeed)
   ' Pas de vérification de GetLastError ici (normalement -> échec avec une erreur 122 - ERROR_INSUFFICIENT_BUFFER)
    ' Redimensionnement de TabInfos selon les besoins
   ReDim TabInfos((TabInfosSizeNeed \ 4))
   ' ... appel à GetPrinter() pour la récupération des infos
   ret = GetPrinter(hPrinter, 2, TabInfos(0), TabInfosSizeNeed, TabInfosSizeNeed)
    'Erreur de GetPrinter : erreurs 0, 6, 1722 ignorées (6 résultant d'un pb de droits utilisateur, 1722, d'une imprimante hors connexion)
   If ret = False Then
       Select Case GetLastError()
           Case 0 To 6
           Case 1722
               MsgBox "Votre imprimante par défaut est hors connexion. Si c'est une imprimante réseau, vérifier que le poste qui y est rattaché est bien allumé", vbExclamation
               Exit Function
           Case Else
               MsgBox "Erreur de l'API GetPrinter Code: " & GetLastError()
               Exit Function
       End Select
   End If
    'Extrait de la structure PRINTER_INFO2 la portion DEVMODE
   pFullDevMode = TabInfos(7)
    'Copie la portion pointée dans la sous-structure créée à cet effet
   Call CopyMemory(NewDevMode, ByVal pFullDevMode, Len(NewDevMode))
   'Changement du format du papier et/ou de l'orientation et/ou du bac
   With NewDevMode
       'Bac
       If pNewBin > 0 And pNewBin < 5 Then
           pOldBin = .dmDefaultSource
           .dmDefaultSource = pNewBin
       End If
   End With
    'Mise à jour du pointeur
   Call CopyMemory(ByVal pFullDevMode, NewDevMode, Len(NewDevMode))
   'Mise à jour des infos dans la structure propre à l'imprimante
   ret = DocumentProperties(0&, hPrinter, NomImpr, ByVal pFullDevMode, ByVal pFullDevMode, DM_IN_BUFFER Or DM_OUT_BUFFER)
   'Mise à jour des propriétés (Windows) de l'imprimante
   ret = SetPrinter(hPrinter, 2, TabInfos(0), 0&)
    'Erreur de SetPrinter : erreurs 0, 6, 1722 ignorées (6 résultant d'un pb de droits utilisateur, 1722, d'une imprimante hors connexion)
   If ret = False Then
       Select Case GetLastError()
           Case 0 To 6
           Case 1722
               MsgBox "Votre imprimante par défaut est hors connexion. Si c'est une imprimante réseau, vérifier que le poste qui y est rattaché est bien allumé", vbExclamation
               Exit Function
           Case Else
               MsgBox "Erreur de l'API GetPrinter Code: " & GetLastError()
               Exit Function
       End Select
   End If
   'Fermeture du handle del'imprimante
   ClosePrinter (hPrinter)
   ChangePrinterSettings = True
   Exit Function

ChangePrinterSettingsError:
   Select Case Err.Number
       Case 9, 484
           'Err 9 : Débordement de tableau causé par un gestionnaire d'imprimante absent ou non accessible
           'Err 484 : Pb d'accès au gestionnaire d'imprimante
           Exit Function
        Case Else
           rep = MsgBox("Erreur : " & Err.Number & "(" & Err.Description & ")" & vbCrLf & "Continuez l'exécution de cette procédure ?", vbQuestion + vbYesNo, "APIs.BAS[ChangePrinterSettings]")
           If rep = vbYes Then Resume Next Else Exit Function
   End Select
End Function
'-----------------------------------------------------------
Private Sub ListeBacsImpr()
' Mémorise les noms de bacs de l'imprimante NomImpr
  Dim Prn As String
  Dim Port As String
  Dim NbBacs As Long
  Dim CT As Long
  Dim ListeDesNoms As String
  Dim ch1 As String
  Dim ch2 As String
  Prn = NomImpr
   ' le paramètre dc_bins permet d'obtenir le nombre de bacs de papier
   NbBacs = DeviceCapabilities(Prn, Port, DC_BINS, ByVal vbNullString, 0)
   ReDim Bacs(1 To NbBacs)
   ListeDesNoms = String(24 * NbBacs, 0)
   NbBacs = DeviceCapabilities(Prn, Port, DC_BINNAMES, ByVal ListeDesNoms, 0)
   ' les noms des bacs sont mis dans le tableau Bacs
   For CT = 1 To NbBacs
      ch1 = Mid(ListeDesNoms, 24 * (CT - 1) + 1, 24)
      ch2 = Left(ch1, InStr(1, ch1, Chr(0)) - 1)
      Debug.Print ch2
      Bacs(CT) = ch2
   Next CT

End Sub
'-----------------------------------------------------------
Sub ChangeBac(NomBac As String)
Dim i As Integer
Dim Ancien As Integer
Dim NumBac As Integer
ListeBacsImpr
NumBac = 0
For i = 1 To UBound(Bacs)
 If Bacs(i) = NomBac Then NumBac = i
Next
If NumBac = 0 Then
 MsgBox "Nom de bac inexistant : " & NomBac
 End
End If
' Retourne le numéro du bac affecté dans Ancien
' et affecte NumBac
Call ChangePrinterSettings(Ancien, NumBac)
End Sub

'-----------------------------------------------------------
Sub Imprimer_FeuilleActive()
Dim NomBacUtilisé As String
Dim NomBacParDefaut As String

NomBacUtilisé = "Réceptacle arrière"
NomBacParDefaut = "Cassette"

'Changer le bac pour celui requis
Call ChangeBac(NomBacUtilisé)

'Imprime la plage de cellule A1:A10
'de la feuille 1 du classeur
Worksheets(1).Range("A1:A10").PrintOut

'Remettre le bac par défaut
Call ChangeBac(NomBacParDefaut)

End Sub '-----------------------------------------------------------   MichD

"bececoste49" a écrit dans le message de groupe de discussion : ******@communitybridge2.codeplex.com.excel...

Bonsoir,

Absente durant quelques semaines, je n'ai pas relancé plus tôt ma demande faisant l'objet du sujet suivant :

http://answers.microsoft.com/fr-fr/office/forum/office_2010-customize/macro-pour-choix-entre-2-fonctions-imprimantes/8ade7cbd-5821-4ac8-9538-d98317796f3e?page=1

En effet, la réponse que j'ai obtenue me satisfaisait pleinement concernant Word.

Par contre, j'aimerais obtenir l'équivalent avec Excel car je ne parviens pas à faire fonctionner cette macro avec ce logiciel.

En espérant vraiment que vous pourrez m'aider.

Je vous en remercie à l'avance
 -- http://answers.microsoft.com/message/da3166b6-2899-4e84-8bd8-e1450e67b8ca
Meta tags: office_2010; excel; 401f8fb0-000c-4e12-b99b-9a4d54b284f7

Thu, 28 Feb 2013 22:36:13  +0000: CreateMessage  bececoste49

J'ai une piste.

J'attends avec impatience !!

En tous cas, merci de ta patience.

Il y a forcément la même erreur. mdr

... sait-on jamais !! J'avais quand même tenté...