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
| Option Explicit
Private Const CFile As String = "C:\Users\Bus\Desktop\divers\Ressources\Admission\"
Private Const CFile2 As String = "C:\Users\Bus\Desktop\divers\"
Private Const service As String = " 7/s"
Private Const Chef As String = "Auie y"
Public DocEnCours As Document
Public HeureArrêt As Date
Public heure
Public Continuer As Boolean
Public Cherche As String
Private Sub Lancer_Click()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim i As Integer
Dim prenom As String, Nom As String, datearive As String, file As String, file1 As String, file2 As String
datearive = ActiveDocument.Tables(1).Rows(1).Cells(3).Range
prenom = ActiveDocument.Tables(1).Rows(1).Cells(2).Range
Nom = ActiveDocument.Tables(1).Rows(1).Cells(1).Range
file = CFile2 & "Transmission.docm"
file1 = CFile & Nom & " " & prenom & "Notes\recup.docm"
file2 = CFile & Nom & " " & prenom & "Notes\Observation de " & Nom & " " & prenom & ".docm"
'On Error Resume Next
OuvrirFichier ("file")
With Selection.Find
.Text = datearive
.Forward = True
.Wrap = wdFindStop
End With
Selection.Find.Execute
Selection.MoveUp Unit:=wdScreen, Count:=27, Extend:=wdExtend
Selection.Copy
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Add
WordDoc.SaveAs "file1"
With Documents("recup.docm")
For i = 1 To .Paragraphs.Count
.Paragraphs(i).Range.Select
If InStr(1, Selection.Text, prenom, vbTextCompare) > 0 Then
Selection.Copy
With Documents(file2)
.Select
With Selection
.EndKey Unit:=6
Selection.Range.Paste
End With
End With
End If
Next i
End With
With Documents(file2)
For i = 1 To .Paragraphs.Count
.Paragraphs(i).Range.Select
If InStr(1, Selection.Text, "Présent", vbTextCompare) > 0 Then
Selection.Delete
End If
Next i
End With
Documents("recup.docm").Close SaveChanges:=wdDoNotSaveChanges
Kill (file1)
End Sub
Public Function OuvrirFichier(MonFichier As String)
On Error GoTo OuvertureFichierErreur
'vérifie si le fichier existe
If Len(Dir(MonFichier)) = 0 Then
OuvrirFichier = False
Exit Function
Else
End If
'ouvre le fichier dans son application associée
Dim MonApplication As Object
Set MonApplication = CreateObject("Shell.Application")
MonApplication.Open (MonFichier)
OuvrirFichier = True
Set MonApplication = Nothing
Exit Function
OuvertureFichierErreur:
Set MonApplication = Nothing
OuvrirFichier = False
End Function |
Partager