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
| Sub export_voozanoo()
'Création d'un nouveau classeur excel
Dim appEcxel As Excel.Application
Dim wbkCommandes As Excel.Workbook
Dim wksCommandes As Excel.Worksheet
Set appEcxel = New Excel.Application
Set wbkCommandes = appEcxel.Workbooks.Add
Set wksCommandes = appEcxel.ActiveSheet
'Transformation de la flèche en sablier
DoCmd.Hourglass (False)
'Variables
Dim lig As Integer
Dim col As Integer
Dim expo As String
Dim req As String
'Préparation de la base de donnée et des recordset
Dim dbrage As Database
Dim rstPostex As DAO.Recordset
Dim rstPat As DAO.Recordset
Dim rstAd As DAO.Recordset
Dim rstVil As DAO.Recordset
Dim rstDep As DAO.Recordset
Dim rstPay As DAO.Recordset
Dim rstEpa As DAO.Recordset
Set dbrage = CurrentDb
'requête sélectionnant les épisodes à traiter suivant une date
req = "SELECT * FROM EPISODE_POE WHERE dtecs1 >= #" & InputBox("à partir de quelle date réaliser l'export ?", "Date de l'export") & "#"
'Ouverture des recordset
Set rstPostex = dbrage.OpenRecordset(req, dbOpenDynaset)
Set rstPat = dbrage.OpenRecordset("PATIENT", dbOpenDynaset)
Set rstAd = dbrage.OpenRecordset("ADRESSE", dbOpenDynaset)
Set rstVil = dbrage.OpenRecordset("VILLE", dbOpenDynaset)
Set rstDep = dbrage.OpenRecordset("DEPT", dbOpenDynaset)
Set rstPay = dbrage.OpenRecordset("PAYS", dbOpenDynaset)
Set rstEpa = dbrage.OpenRecordset("EPISODE_ANIMAL", dbOpenDynaset)
'Structure du tableau et ajout des titres sur la première ligne
wksCommandes.Cells(1, 1).Value = "Annee"
wksCommandes.Cells(1, 2).Value = "Age"
wksCommandes.Cells(1, 3).Value = "Sexe"
wksCommandes.Cells(1, 4).Value = "Date expo"
wksCommandes.Cells(1, 5).Value = "Commune expo"
wksCommandes.Cells(1, 6).Value = "CP"
wksCommandes.Cells(1, 7).Value = "Pays"
wksCommandes.Cells(1, 8).Value = "Nature expo"
wksCommandes.Cells(1, 9).Value = "Espèce"
wksCommandes.Cells(1, 10).Value = "Statut animal"
wksCommandes.Cells(1, 11).Value = "Traitement"
wksCommandes.Cells(1, 12).Value = "Comment"
'Initialisation des numéros de ligne
lig = 1
'Comptage du nombre di ligne afin de paramétrer la barre de défilement
rstPostex.MoveLast
pg = SysCmd(acSysCmdInitMeter, "Export données pour voozanoo...", rstPostex.RecordCount)
rstPostex.MoveFirst
With rstPostex
Do Until .EOF
lig = lig + 1
col = 1
'Année de déclaration
wksCommandes.Cells(lig, col).Value = Year(Now)
col = col + 1
If Not IsNull(rstPostex("idpat").Value) Then
With rstPat
crit = "idpat = " & rstPostex("idpat").Value
.FindFirst crit
'Age du patient
If Not IsNull(rstPat("dtenaiss").Value) Then
wksCommandes.Cells(lig, col).Value = CInt(Year(Now) - Year(rstPat("dtenaiss").Value))
End If
col = col + 1
'Sexe du patient
If Not IsNull(rstPat("sexepat").Value) Then
wksCommandes.Cells(lig, col).Value = rstPat("sexepat").Value
End If
col = col + 1
End With
Else
col = col + 2
End If
'date d'exposition
If Not IsNull(rstPostex("dteexp").Value) Then
wksCommandes.Cells(lig, col).Value = rstPostex("dteexp").Value
End If
col = col + 1
'Lieu de l'exposition
If Not IsNull(rstPostex("lieuexp").Value) Then
'les communes ne sont à indiquer que dans le cadre d'une exposition en france métropolitaine
'On passe donc cette colonne
col = col + 1
'Code postal
crit = "idad = " & rstPostex("lieuexp").Value
rstAd.FindFirst (crit)
If Not IsNull(rstAd("idville").Value) Then
crit = "idville = " & rstAd("idville").Value
rstVil.FindFirst (crit)
If Not IsNull(rstVil("cp").Value) Then
wksCommandes.Cells(lig, col).Value = rstVil("cp").Value
End If
col = col + 1
If Not IsNull(rstVil("dept").Value) Then
crit = "iddept = " & rstVil("dept").Value
rstDep.FindFirst (crit)
If Not IsNull(rstDep("idpays").Value) Then
crit = "idpays = " & rstDep("idpays").Value
rstPay.FindFirst (crit)
If Not IsNull(rstPay("nompays").Value) Then
wksCommandes.Cells(lig, col).Value = rstPay("nompays").Value
End If
col = col + 1
Else
col = col + 1
End If 'rstdep
Else
col = col + 1
End If 'rstvil
Else
col = col + 2
End If 'rstad
Else
col = col + 3
End If 'lieuexp
expo = ""
'Nature de l'exposition
If rstPostex("contact").Value = "Vrai" Then
expo = expo & "contact"
End If
If rstPostex("lechage").Value = "Vrai" Then
expo = expo & " lechage"
End If
If rstPostex("griffure").Value = "Vrai" Then
expo = expo & " griffure"
End If
If rstPostex("morsure").Value = "Vrai" Then
expo = expo & " morsure"
End If
If Not IsNull(expo) Then
wksCommandes.Cells(lig, col).Value = expo
End If
col = col + 1
'espèce de l'animal suspect
crit = "idepi = " & rstPostex("idepi").Value
rstEpa.FindFirst (crit)
If Not IsNull(rstEpa("aniesp").Value) Then
wksCommandes.Cells(lig, col).Value = rstEpa("aniesp").Value
End If
col = col + 1
If Not IsNull(rstEpa("statvcc").Value) Then
wksCommandes.Cells(lig, col).Value = rstEpa("statvcc").Value
End If
col = col + 1
'Traitement
If rstPostex("vcc").Value = "Vrai" Then
wksCommandes.Cells(lig, col).Value = "Oui"
Else
wksCommandes.Cells(lig, col).Value = "Non"
End If
col = col + 1
'Commentaires général
If Not IsNull(rstPostex("rmqepi").Value) Then
wksCommandes.Cells(lig, col).Value = rstPostex("rmqepi").Value
End If
'Boucle sur les fiches
.MoveNext
Loop
End With
'Enregistrement du classeur excel
feuilleExcel = CurrentProject.Path & "\" & Year(Now) & Month(Now) & Day(Now) & "voozanoo.xlsx"
wksCommandes.SaveAs (feuilleExcel)
wbkCommandes.Close
'Destruction des références
Set wksCommandes = Nothing
Set wbkCommandes = Nothing
Set appEcxel = Nothing
rstPostex.Close
rstPat.Close
rstAd.Close
rstVil.Close
rstDep.Close
rstPay.Close
rstEpa.Close
dbrage.Close
Set dbrage = Nothing
Set rstPostex = Nothing
Set rstPat = Nothing
Set rstAd = Nothing
Set rstVil = Nothing
Set rstDep = Nothing
Set rstPay = Nothing
Set rstEpa = Nothing
'Supprimer la barre de progression
pg = SysCmd(acSysCmdRemoveMeter)
'faire disparaitre le sablier
DoCmd.Hourglass (False)
End Sub |
Partager