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
| Option Compare Database
Option Explicit
Private Sub buEnvoiMail2_Click()
On Error Resume Next
'Déclaration dea variables et des fonctions
Dim db As DAO.Database, qry As QueryDef
Dim rs As DAO.Recordset
Dim req As DAO.Recordset
Dim mail, erreur As String
Dim Entreprise As String
Set db = CurrentDb
'contrôle si la requête ReqEmail existe si non on la créé
Set qry = db.QueryDefs("ReqEmail")
If Err.Number <> 0 Then
Set qry = db.CreateQueryDef("ReqEmail")
Err.Clear
End If
'Selection des nom et adresses email des entreprises
'J'ai créé une nouvelle table car la personne qui a créé la table d'orginine a mis des espaces dans le nom!!!!!!
Set rs = CurrentDb.OpenRecordset("SELECT [tbl_Maisons].Entreprise, [tbl_Maisons].[EMail] FROM [tbl_Maisons];")
'Boucle qui passe en revue toutes les entreprises
While Not rs.EOF
'Création de la requête avec les variables de l'entreprise en cours...
qry.SQL = "PARAMETERS semaine Value;" & _
" SELECT Regie_base2.Societe, [Rqt_base_Analyse croisée].semaine,[tbl_Maisons].N° AS Code," & _
" [tbl_Maisons].Entreprise, Last(Regie_base2.Branche) AS DernierDeBranche, Last([tbl_Maisons].Nom) AS Reference, Last([tbl_Maisons].Rue) AS DernierDeRue," & _
" Last([tbl_Maisons].Npa) AS DernierDeNpa, Last([tbl_Maisons].Ville) AS DernierDeVille, Last([tbl_Maisons].Fax) AS DernierDeFax, Last(Regie_base2.Qualite) AS DernierDeQualite, " & _
" Last(Regie_horaire.Matricule) AS DernierDeMatricule, Last(Regie_base2.Nom) AS DernierDeNom, Last(Regie_base2.Prenom) AS DernierDePrenom, Last(Regie_base2.Centre_cout) AS DernierDeCentre_cout," & _
" Last([Rqt_base_Analyse croisée].[Total de Heures]) AS [DernierDeTotal de Heures], Last(Regie_base2.Tarif) AS DernierDeTarif, Last(([Total de Heures]*[Tarif])) AS Montant, [Rqt_base_Analyse croisée].lun," & _
" [Rqt_base_Analyse croisée].mar, [Rqt_base_Analyse croisée].mer, [Rqt_base_Analyse croisée].jeu, [Rqt_base_Analyse croisée].ven, [Rqt_base_Analyse croisée].sam, [Rqt_base_Analyse croisée].dim" & _
" FROM ([Rqt_base_Analyse croisée] LEFT JOIN Regie_horaire ON [Rqt_base_Analyse croisée].Matricule = Regie_horaire.Matricule) LEFT JOIN (Regie_base2 LEFT JOIN [tbl_Maisons] ON Regie_base2.Code = [tbl_Maisons].N°)" & _
" ON [Rqt_base_Analyse croisée].Matricule = Regie_base2.Matricule" & _
" WHERE [tbl_Maisons].Entreprise = " & Chr(34) & rs("Entreprise") & Chr(34) & _
" GROUP BY Regie_base2.Societe, [Rqt_base_Analyse croisée].semaine, [tbl_Maisons].N°, [tbl_Maisons].Entreprise, [Rqt_base_Analyse croisée].lun, [Rqt_base_Analyse croisée].mar, [Rqt_base_Analyse croisée].mer, [Rqt_base_Analyse croisée].jeu, [Rqt_base_Analyse croisée].ven, [Rqt_base_Analyse croisée].sam, [Rqt_base_Analyse croisée].dim" & _
" HAVING (((Regie_base2.Societe) = 'cimo') And (([Rqt_base_Analyse croisée].semaine) = [semaine]))" & _
" ORDER BY [tbl_Maisons].Entreprise DESC;"
'La variable entreprise prend le nom de l'entreprise en cours
Entreprise = rs("Entreprise")
'La variable mail prend l'email de l'entreprise en cours
mail = rs("EMail")
'test pour savoir s'il existe une adresse email
If (mail <> "") Then
'envoi de l'état en format snp à l'adresse email correspondant
DoCmd.SendObject acReport, "etEmail", acFormatSNP, mail, , , , Chr(10) & Chr(10) & "Si vous n'arrivez pas à ouvrir le document, vous pouvez télécharger le programme a cette adresse :" & Chr(10) & "http://www.microsoft.com/downloads/details.aspx?familyid=b73df33f-6d74-423d-8274-8b7e6313edfb&displaylang=fr "
'si l'entreprise n'a pas d'adresse email un message d'erreur s'affiche
Else
erreur = MsgBox("Il n'y a pas d'adresse email pour l'entreprise :" & Entreprise, vbOKOnly, "Email invalide")
End If
'En cas d'annulation de l'utilisateur on passe à l'entreprise suivante
On Error Resume Next
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
Set db = Nothing
erreur:
MsgBox "Le mail n'a pas été envoyé", , "Action annulée"
Exit Sub
End Sub
Private Sub ImprimerPDF_Click()
'Declaration des fonctions
Private originalPrinter As String
Public Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
(ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, _
ByVal lpReturnedString$, ByVal nSize&) As Long
Public Declare Function WriteProfileString Lib "kernel32" Alias _
"WriteProfileStringA" (ByVal lpszSection$, ByVal lpszKeyName$, _
ByVal lpszString$) As Long
subCreatePDFFromReport "etEmail etEmail", "J:\Hr\Régies\Test\pdf\etEmail.pdf"
End Sub
Private Sub ValidationEntreprises_Click()
'Traitement des erreurs
On Error GoTo Err_ValidationEntreprises_Click
'Lancement de la requete qui vide la table tbl_Maisons
DoCmd.OpenQuery "qry_suppresion_maisons"
'Lancement de la requête qui ajoute les entreprises cochées à la table tbl_Maisons
DoCmd.OpenQuery "qry_Remplir_maisons"
Exit_ValidationEntreprises_Click:
Exit Sub
'Affiche un message avec la description de l'erreur et quitte la fonction
Err_ValidationEntreprises_Click:
MsgBox Err.Description
Resume Exit_ValidationEntreprises_Click
End Sub
Public Function fnctGetDefaultPrinter() As String
'L'ensemble du code ci-dessous est destiné à être utilisé avec PDFWriter d' Acrobat.
'De plus, l'installation d'Acrobat doit être faite en mode personnalisé afin de cocher la case PDFWriter
'qui n'est pas installé en mode Par défaut.
'Obtention et définition temporaire dynamique des paramètres d'impression:
Dim nSize As Integer
Dim strPrinterName As String
Dim successReturn&
Dim iPos1 As Integer, iPos2 As Integer
nSize = 81
strPrinterName = Space(nSize)
successReturn = GetProfileString("windows", "device", _
vbNullString, strPrinterName, nSize)
strPrinterName = Left(strPrinterName, successReturn)
iPos1 = InStr(1, strPrinterName, ",")
iPos2 = InStr(iPos1 + 1, strPrinterName, ",")
strPrinterName = Left(strPrinterName, iPos1 - 1)
fnctGetDefaultPrinter = strPrinterName
End Function
Private Sub subGetDriverAndPort(ByVal Buffer As String, _
ByRef DriverName As String, ByRef PrinterPort As String)
Dim posDriver As Integer
Dim posPort As Integer
DriverName = vbNullString
PrinterPort = vbNullString
posDriver = InStr(Buffer, ",")
If posDriver > 0 Then
DriverName = Left(Buffer, posDriver - 1)
posPort = InStr(posDriver + 1, Buffer, ",")
If posPort > 0 Then
PrinterPort = Mid(Buffer, posDriver + 1, posPort - posDriver - 1)
End If
End If
End Sub
Private Sub SetDefaultPrinter(ByVal PrinterName As String)
Dim Buffer As String
Dim DeviceName As String
Dim DriverName As String
Dim PrinterPort As String
Dim DeviceLine As String
Buffer = Space(1024)
Call GetProfileString("PrinterPorts", PrinterName, vbNullString, _
Buffer, Len(Buffer))
subGetDriverAndPort Buffer, DriverName, PrinterPort
If DriverName <> vbNullString And PrinterPort <> vbNullString Then
DeviceLine = PrinterName & "," & DriverName & "," & PrinterPort
Call WriteProfileString("windows", "Device", DeviceLine)
End If
End Sub
'Creation du pdf
Private Sub subCreatePDFFromReport(ByVal ReportName As String, _
ByVal PDFFileName As String)
originalPrinter = fnctGetDefaultPrinter()
SetDefaultPrinter "Acrobat PDFWriter"
subRegistrySetKeyValue rootHKeyCurrentUser, _
"Software\Adobe\Acrobat PDFWriter\", "PDFFileName", _
PDFFileName, RRKREGSZ
DoCmd.OpenReport ReportName, 0
SetDefaultPrinter originalPrinter
End Sub |
