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 |
Partager