Configuration boîte de dialogue Imprimer

**lito74** · 04/09/2010, 11h28

Bonjour, j'ai trouver le code de Arkham46.
Serait-il possible de ne faire apparaître qu'une seule imprimante (l'imprimante pdfcreator pour être exact) dans la liste ?
Merci pour vos réponses

**hocine** · 06/09/2010, 15h31

Salut,
essaye
avant le getprinterrowsource:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
if lPrinterName="pdfcreator" then 'essaye de trouver le nom exacte
GetPrinterRowSource = GetPrinterRowSource & lPrinterName & ";"
end if

Bonne chance.
MERCI

**lito74** · 07/09/2010, 16h53

Merci Hocine pour ta réponse
Malheureusement j'ai toujours la liste de toutes les imprimantes dans la liste déroulante....

**Arkham46** · 07/09/2010, 20h45

Bjr,

La fonction GetPrinterRowSource est complétement déconnectée de la boîte de dialogue.
Elle peut servir à vérifier si une imprimante existe, ou à remplir une zone de liste.

J'ai rajouté un paramètre pRemoveOtherPrinter au module de code ci-dessous :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
 
Option Explicit
 
'---------------------------------------------------------------------------------------
'*                        Boîte dialogue d'impression étendue                          *
'---------------------------------------------------------------------------------------
' Ajout de pRemoveOtherPrinter pour ne laisser dans la liste que pPrinter
'---------------------------------------------------------------------------------------
'***************************************************************************************
'*                                       API                                           *
'***************************************************************************************
' Pour remplacement de AddressOf  Access 97
#If VBA6 Then
#Else
    Private Declare Function GetCurrentVbaProject _
        Lib "vba332.dll" Alias "EbGetExecutingProj" (hProject As Long) As Long
    Private Declare Function GetFuncID _
        Lib "vba332.dll" Alias "TipGetFunctionId" (ByVal hProject As Long, _
            ByVal strFunctionName As String, ByRef strFunctionId As String) As Long
    Private Declare Function GetAddr _
        Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" (ByVal hProject As Long, _
            ByVal strFunctionId As String, ByRef lpfn As Long) As Long
#End If
' Déplace une zone de mémoire
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, _
    ByVal length As Long)
' Récupère les couleurs système
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, _
    ByVal nIDDlgItem As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, _
    ByVal nIndex As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias _
    "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
    ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, _
    ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, _
    ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As Long, _
    ByVal lpString As String) As Long
Private Declare Function GetProfileSection Lib "kernel32" Alias _
    "GetProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As String, _
    ByVal nSize As Long) As Long
'***************************************************************************************
'*                                       Types                                         *
'***************************************************************************************
' Type Point pour API
Private Type CWPSTRUCT
    lParam As Long
    wParam As Long
    message As Long
    hWnd As Long
End Type
'***************************************************************************************
'*                                    Constantes                                       *
'***************************************************************************************
Private Const GWL_HINSTANCE = (-6)
Private Const WH_CALLWNDPROC = 4
Private Const WM_ACTIVATE = &H6
Private Const WM_SETTEXT = &HC
Private Const BM_CLICK = &HF5
Private Const MAX_SECTION = 2048
Private Const CB_SETCURSEL = &H14E
Private Const WM_COMMAND = &H111
Private Const CBN_SELCHANGE = 1
Private Const CB_GETLBTEXT = &H148
Private Const CB_GETCOUNT = &H146
Private Const CB_DELETESTRING = &H144
'***************************************************************************************
'*                                    Variables                                        *
'***************************************************************************************
' Variables de fonctionnement de PrintBox
Private PB_NbCopies As String
Private PB_SortPages As Boolean
Private PB_PageFrom As String
Private PB_pageTo As String
Private PB_Title As String
Private PB_PrintImmediate As Boolean
Private PB_Printer As String
Private PB_RemoveOtherPrinter As Boolean
Private PB_AppOldProc As Long  ' Procédure de gestion des messages de la fenêtre d'application
'***************************************************************************************
'*                                    FONCTIONS                                        *
'***************************************************************************************
 
'---------------------------------------------------------------------------------------
' Gestion des messages de l'application en attente d'ouverture de la boîte de dialogue
'---------------------------------------------------------------------------------------
' wParam et lParam    : Paramètres du message
'---------------------------------------------------------------------------------------
Private Function AppProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lCWP As CWPSTRUCT   ' Structure pour paramètres des messages
    Dim lClass As String    ' Nom de la classe de la fenêtre
    Dim lHwnd As Long
    Dim lPos As Long
    Dim lRet As Long
    Dim lTexte As String
    Dim lCount As Long
    Dim lSelected As Boolean
    On Error Resume Next    ' Pas de capture d'erreur dans les fonctions CallBack
    ' Copie les paramètres dans une structure
    RtlMoveMemory lCWP, ByVal lParam, Len(lCWP)
    ' Si message de création
    If lCWP.message = WM_ACTIVATE Then
        ' Lecture du nom de la classe
        lClass = Space(255)
        lClass = Left(lClass, GetClassName(lCWP.hWnd, ByVal lClass, 255))
        ' Les boîtes de dialogue ont comme classe : #32770
        If lClass = "#32770" Then
            If PB_Title <> "" Then
                SetWindowText lCWP.hWnd, PB_Title
            End If
            If PB_Printer <> "" Then
                ' Choix de l'imprimante
                lHwnd = GetDlgItem(lCWP.hWnd, 1139)
                lCount = SendMessage(lHwnd, CB_GETCOUNT, 0, ByVal 0&)
                lPos = 0
                Do
                    If lPos > lCount - 1 Then Exit Do
                    lTexte = Space(255)
                    lRet = SendMessage(lHwnd, CB_GETLBTEXT, lPos, ByVal lTexte)
                    lTexte = Left(lTexte, lRet)
                    If UCase(lTexte) Like UCase(PB_Printer) Then
                        If Not lSelected Then ' sélectionne le premier trouvé
                            Call SendMessage(lHwnd, CB_SETCURSEL, lPos, ByVal 0&)
                            SendMessage lCWP.hWnd, WM_COMMAND, _
                                (CBN_SELCHANGE * &H10000) + 1139, ByVal lHwnd
                            lSelected = True
                        End If
                        If Not PB_RemoveOtherPrinter Then Exit Do
                    ElseIf PB_RemoveOtherPrinter Then
                         Call SendMessage(lHwnd, CB_DELETESTRING, lPos, ByVal 0&)
                         lPos = lPos - 1
                         lCount = lCount - 1
                    End If
                    lPos = lPos + 1
                Loop
            End If
            If PB_NbCopies <> 1 Then
                ' Recherche de la zone nombre de copies
                lHwnd = GetDlgItem(lCWP.hWnd, 1154)
                ' Met à jour la zone de texte
                Call SendMessage(lHwnd, WM_SETTEXT, Len(PB_NbCopies), ByVal PB_NbCopies)
            End If
            If Not PB_SortPages Then
                ' Recherche de la case triés
                lHwnd = GetDlgItem(lCWP.hWnd, 1041)
                Call SendMessage(lHwnd, BM_CLICK, 0, 0&)
            End If
            If PB_PageFrom > 0 Or PB_pageTo > 0 Then
                ' Click sur la case pages
                lHwnd = GetDlgItem(lCWP.hWnd, 1058)
                Call SendMessage(lHwnd, BM_CLICK, 0, 0&)
                ' Pages à imprimer
                lHwnd = GetDlgItem(lCWP.hWnd, 1152)
                Call SendMessage(lHwnd, WM_SETTEXT, Len(PB_PageFrom), ByVal PB_PageFrom)
                lHwnd = GetDlgItem(lCWP.hWnd, 1153)
                Call SendMessage(lHwnd, WM_SETTEXT, Len(PB_pageTo), ByVal PB_pageTo)
            End If
            If PB_PrintImmediate Then
                ' Click sur bouton OK
                lHwnd = GetDlgItem(lCWP.hWnd, 1)
                Call SendMessage(lHwnd, BM_CLICK, 0, 0&)
            End If
            ' Stoppe la surveillance des messages
            Call UnhookWindowsHookEx(PB_AppOldProc)
        End If
    End If
    ' Appelle la fonction de gestion des messages d'origine
    AppProc = CallNextHookEx(PB_AppOldProc, nCode, wParam, ByVal lParam)
End Function
 
'---------------------------------------------------------------------------------------
' Fonction publique d'appel de la boîte de dialogue d'impression
'---------------------------------------------------------------------------------------
Public Function PrintBox(Optional pTitle As String = "", _
                Optional pPrinter As String, _
                Optional pNbCopies As Integer = 1, _
                Optional pSortPages As Boolean = True, _
                Optional pPageFrom As Integer, Optional pPageto As Integer, _
                Optional pPrintImmediate As Boolean = False, Optional pRemoveOtherPrinter As Boolean)
    On Error GoTo Gestion_Erreurs
    ' Titre de la fenêtre
    PB_Title = pTitle
    ' Nombre de copies
    PB_NbCopies = pNbCopies
    ' Trier les pages
    PB_SortPages = pSortPages
    ' Pages à imprimer
    PB_PageFrom = pPageFrom
    PB_pageTo = pPageto
    ' Impression immédiate
    PB_PrintImmediate = pPrintImmediate
    ' Imprimante
    PB_Printer = pPrinter
    ' Imprimante à retirer de la liste
    PB_RemoveOtherPrinter = pRemoveOtherPrinter
    ' Surveille les messages de l'application en attente d'ouverture de la boîte de dialogue
    #If VBA6 Then
        PB_AppOldProc = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf AppProc, _
                GetWindowLong(GetForegroundWindow, GWL_HINSTANCE), _
                GetCurrentThreadId())
    #Else
        PB_AppOldProc = SetWindowsHookEx(WH_CALLWNDPROC, AddrOf("AppProc"), _
                GetWindowLong(GetForegroundWindow, GWL_HINSTANCE), _
                GetCurrentThreadId())
    #End If
    ' Appel la boîte de dialogue d'impression standard
    DoCmd.RunCommand acCmdPrint
    ' Stoppe la surveillance des messages
    Call UnhookWindowsHookEx(PB_AppOldProc)
Gestion_Erreurs:
    If Err.Number <> 0 Then MsgBox Err.Description
End Function
 
'---------------------------------------------------------------------------------------
' Remplacement de AddressOf Pour Access 97
'---------------------------------------------------------------------------------------
#If VBA6 Then
#Else
Private Function AddrOf(strFuncName As String) As Long
    Dim hProject As Long
    Dim lngResult As Long
    Dim strID As String
    Dim lpfn As Long
    Dim strFuncNameUnicode As String
 
    Const NO_ERROR = 0
    strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
    Call GetCurrentVbaProject(hProject)
    If hProject <> 0 Then
        lngResult = GetFuncID(hProject, strFuncNameUnicode, strID)
        If lngResult = NO_ERROR Then
            lngResult = GetAddr(hProject, strID, lpfn)
            If lngResult = NO_ERROR Then
                AddrOf = lpfn
            End If
        End If
    End If
End Function
#End If
 
'---------------------------------------------------------------------------------------
' Renvoie la liste des imprimantes séparées par un point-virgule
'---------------------------------------------------------------------------------------
Public Function GetPrinterRowSource() As String
    Dim lReturn As Integer
    Dim lPrinters As String
    Dim lPrinterName As String
    Dim lPos As Integer
    Dim lPort As String
    lPrinters = Space(MAX_SECTION)
    lReturn = GetProfileSection("Devices", lPrinters, MAX_SECTION)
    lPrinters = Left(lPrinters, lReturn)
    lPos = 1
    Do
        lPos = InStr(1, lPrinters, "=")
        If lPos = 0 Then Exit Do
        lPrinterName = Left(lPrinters, lPos - 1)
        lPos = InStr(1, lPrinters, ",")
        lPrinters = Right(lPrinters, Len(lPrinters) - lPos)
        lPos = InStr(1, lPrinters, Chr(0))
        If lPos <> 0 Then
            lPort = Left(lPrinters, lPos - 2)
            lPrinters = Right(lPrinters, Len(lPrinters) - lPos)
        End If
        GetPrinterRowSource = GetPrinterRowSource & lPrinterName & ";"
    Loop
End Function

Par exemple, pour n'afficher que les imprimantes contenant "pdf" dans leur nom, et sélectionner la première par défaut :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
PrintBox , "*pdf*", , , , , , True

**lito74** · 08/09/2010, 07h28

Merci Arkam46, c'est parfait.
Je vais essayer d'abuser encore un peu de tes grandes connaissances pour savoir s'il est possible :
- de paramètrer la mise à l'échelle dans les options avancées
- d'éviter le message "L'action runcommand a été annuler" lorsque l'on clique sur le bouton 'Annuler'

Encore merci

**Arkham46** · 08/09/2010, 14h23

Envoyé par lito74

- d'éviter le message "L'action runcommand a été annuler" lorsque l'on clique sur le bouton 'Annuler'

là il suffit de récupérer l'erreur avec "on error goto"

tu peux modifier le module pour renvoyer Faux en cas d'erreur :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

public function PrintBox (...) as Boolean

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 
    ' Stoppe la surveillance des messages
    Call UnhookWindowsHookEx(PB_AppOldProc)
    PrintBox = True
    Exit Function
Gestion_Erreurs:
    PrintBox = False
End Function