Boite de dialogue Imprimer [Sources]

**specialfox** · 11/03/2006, 19h39

Bonjour,

Lorsque j'édite un état dans mon programme, j'utilise le code suivant :

Code :

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

1
2
On error resume next
DoCmd.RunCommand acCmdPrint

Cela à pour effet d'afficher la boite de dialogue d'impression de WIndows. L'utilisateur peut alors sélectionner l'imprimante, l'orientation, le nombre de copies.

Mon problème vient du nombre de copie, mon client édite systématiquement ses factures en 3 exemplaires et je voudrais mettre d'office 3 dans la boite de dialogue d'impression, mais impossible.

J'ai essayer plusieurs techniques printer,... mais rien ni fait.

Pouvez-vous m'aider.

Merci A+

**cafeine** · 11/03/2006, 19h51

Hello,

as-tu essayé de faire une boucle sur un DoCmd.PrintOut ?

**specialfox** · 11/03/2006, 20h23

non, je ne connais pas cette fonction.

Je vais essayer de voir si il y a une possibilité de passer le nombre de copie.

A+

**specialfox** · 11/03/2006, 20h31

J'ai essayé la commande suivante :

Code :

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

docmd.printout , , , , 3

Effectivement cela permet de lancer 3 impressions de mon état, mais ce qui aurait était le top, c'est que le nombre 3 apparaisse directement dans la boite de dialogue d'impression.

Pour l'instant je vais faire 2 boutons Imprimer :
1 avec la possiblité de choisir une imprimante ou une imprimante PDf et de modifier quelques paramètres
1 autre bouton d'impression rapide avec directement 3 exemplaires.

Merci. Mais si vous avez une solution, je suis preneur.

PS: peut-être dans le forum visual basic...

A+

**Arkham46** · 11/03/2006, 22h41

slt,

En mettant le code en fin message dans un module tu as une fonction PrintBox avec plusieurs options:
pTitle : Titre de la boîte de message
pPrinter : Nom de l'imprimante (ça marche avec des *, genre "*PDP*")
pNbCopies : Nombre de copie
pSortPages : Tri des pages si plusieurs copies
pPageFrom et pPageto : Pages à imprimer
pPrintImmediate : Impression immédiate

Les paramètres sont tous optionnels.

Et y a une fonction GetPrinterRowSource qui renvoie la liste des imprimantes séparées par des point-virgules, donc pratique pour mettre dans une liste déroulante.

Tu remplaces donc le :

Code :

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

DoCmd.RunCommand acCmdPrint

par par exemple :

Code :

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

PrintBox "Impression PDF","*PDF*",3

Ca mérite juste d'être un peu testé, je viens de finir cette usine à gaz...

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
Option Compare Database
Option Explicit
 
'---------------------------------------------------------------------------------------
'*                        Boîte dialogue d'impression étendue                          *
'---------------------------------------------------------------------------------------
 
'***************************************************************************************
'*                                       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
'***************************************************************************************
'*                                    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_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
    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)
                For lPos = 0 To SendMessage(lHwnd, CB_GETCOUNT, 0, 0&)
                    lTexte = Space(255)
                    lRet = SendMessage(lHwnd, CB_GETLBTEXT, lPos, ByVal lTexte)
                    If Left(lTexte, lRet) Like PB_Printer Then
                        Call SendMessage(lHwnd, CB_SETCURSEL, lPos, 0&)
                        SendMessage lCWP.hWnd, WM_COMMAND, (CBN_SELCHANGE * &H10000) + 1139, lHwnd
                        Exit For
                    End If
                Next
            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)
    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
    ' 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

**specialfox** · 12/03/2006, 11h48

Merci pour ce code.

Lorsque je compile mon projet j'ai une erreur sur cette ligne

Code :

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

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

Le message d'erreur est le suivant :

Code :

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

Erreur de compilation : Nom ambigu détecté : sendmessage

Si je le mets en commentaire tout marche très bien, la mise à jour dans la boite d'impression ce fait bien.

Un grand merci pour ce code.

PS: Avant de résoudre ce problème peux-tu me dire à quoi sert cette ligne.
Par la suite il serait peut intéressant de mettre ce code dans la FAQ VBA.

A+

**specialfox** · 12/03/2006, 11h51

j'aurai dû tourner ma langue dans ma bouche, je viens de m'apercevoir, que j'utilise déjà cette déclaration, pour récupérer la résolution de l'écran.

Le sujet est clos.

Bravo pour ce forum et encore merci à Arkham46 pour ce bout de code.

A+

**Arkham46** · 12/03/2006, 14h24

c'est bête ça, je me suis rendu compte qu'entre hier et aujoud'hui les imprimantes ne sont plus dans la même position avec GetProfileSection...

donc j'ai changé le code pour chercher l'imprimante dans la combobox pour être sûr de trouver la bonne position.

bye.

Boite de dialogue Imprimer [Sources]

Access

Discussions similaires

Partager

Partager