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
| Private Sub CmdOk_Click()
'On utilise des recordset :
bordereau
'Eploitation des recordset
'On vérifie qu'il retourne au moin une ligne :
If rsBordereau.EOF Then
'Si au moins un tuple existe ...
'On vérifie que le bordereau (NomFichier) se trouve bien _
dans le dossier (CheminDossier) ...
' With Application.FileSearch
' .lookin = CheminDossier
' .FileName = NomFichier
' .filetype = msoFileTypeAllFiles
' .Searchsubfolders = True
' If .Execute Then
'Si le fichier est là ... _
... on ouvre le dit fichier :
'on déclare les objets, ...
Dim appexcel As Excel.Application
Dim wbexcel As Excel.Workbook
'... on appele le fichier excel ...
Set appexcel = CreateObject("Excel.Application")
appexcel.Visible = True
Set wbexcel = appexcel.Workbooks.Open("z:\bordereau.xls")
'... on Appele la feuille correspondante :
appexcel.Sheets("Bordereau").Select
'... quelques traitements s'imposent ...
'Ajout de bloc de 3 lignes en fonction du NbLigneTotal ...
i = 1
Do Until rsNbLigneTotal.EOF And i = rsNbLigneTotal![NbLigneTotal]
Range("A" & 16 + (i - 1) * 3 & ":M" & 18 + (i - 1) * 3).Select
Selection.Copy
Range("A" & 19 + (i - 1) * 3 & ":M" & 21 + (i - 1) * 3).Select
Selection.Insert Shift:=xlDown
'... insertion du n° d'ordre ...
xlSheet.Cells(13 + (i - 1) * 3, 1) = i
'... insertion des données ds les lignes ...
j = 0
Do Until rsNbLigneParPatient.EOF And j = rsNbLigneParPatient![NbLignePatient] - 1
appexcel.Cells(16 + j + (i - 1) * 3, 2) = rsBordereau![NomPatient]
appexcel.Cells(16 + j + (i - 1) * 3, 3) = rsBordereau![PrenomPatient]
appexcel.Cells(16 + j + (i - 1) * 3, 4) = rsBordereau![NumSSPatientPatient]
appexcel.Cells(16 + j + (i - 1) * 3, 5) = rsBordereau![NomPraticien]
appexcel.Cells(16 + j + (i - 1) * 3, 6) = rsBordereau![PrenomPraticien]
appexcel.Cells(16 + j + (i - 1) * 3, 7) = rsBordereau![NomPatient]
appexcel.Cells(16 + j + (i - 1) * 3, 8) = rsBordereau![TauxPriseEnCahrge]
appexcel.Cells(16 + j + (i - 1) * 3, 3) = rsBordereau![DateActe]
If rsBordereau![ModifActe1] = "" And rsBordereau![ModifActe2] = "" Then
appexcel.Cells(16 + j + (i - 1) * 3, 4) = rsBordereau![CodeActe]
Else
If rsBordereau![ModifActe1] = "" Or rsBordereau![ModifActe2] = "" Then
If rsBordereau![ModifActe1] = "" Then
appexcel.Cells(16 + j + (i - 1) * 3, 4) =
rsBordereau![CodeActe] & " " & rsBordereau![ModifActe2]
Else
appexcel.Cells(16 + j + (i - 1) * 3, 4) =
rsBordereau![CodeActe] & " " & rsBordereau![ModifActe1]
End If
Else
appexcel.Cells(16 + j + (i - 1) * 3, 4) =
rsBordereau![CodeActe] & " " & rsBordereau![ModifActe1] & " + " & rsBordereau![ModifActe2]
End If
End If
'... incrémentation des enregistrement ...
rsBordereau.MoveNext
j = j + 1
Loop rsNbLigneParPatient.MoveNext
i = i + 1
Loop
'On peut alors fermer le formulaire courant :
DoCmd.Close
' Else
' 'Si le fichier n'est pas là :
' MsgBox "Le fichier " & NomFichier & " est introuvable !" _
' & vbCrLf & " Vérifier que " & CheminDossier & " est le bon chemin d'accès." _
' & vbCrLf & " Si besoin changer le chemin d'accès dans les paramètres" _
' & vbCrLf & " ou contactez votre administrateur systeme."
' End If
' End With
Else
'S'il n'y a aucune ligne renvoyée on prévient l'utilsateur ...
MsgBox "L'intervalle des dates sélectionnées ne renvoie aucunes lignes !"
'... on ferme le formulaire ...
DoCmd.Close
'... et on revient à l'acceuil :
DoCmd.OpenForm "Acceuil", acNormal
End If
End Sub |
Partager