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
| Private Sub Lancer_Click()
Dim i As Integer, j As Integer
Dim prenom As String, Nom As String, datearive As String _
, file As String, file1 As String, file2 As String, file3 As String _
, file4 As String, file5 As String, file6 As String, date2 As String, FichierWord
Dim oTbl As Table
Set oTbl = ActiveDocument.Tables(1)
datearive = netText(oTbl.Cell(1, 3).Range.Text)
prenom = netText(oTbl.Cell(1, 2).Range.Text)
Nom = netText(oTbl.Cell(1, 1).Range.Text)
file = CFile & Nom & " " & prenom & "\Notes\"
file1 = "Observation de " & Nom & " " & prenom & ".docm"
file2 = CFile & "Recup.dotm"
file3 = CFile2 & "Transmission.docm"
file5 = CFile & "\Notes\recup2.docm"
file6 = CFile & "\Notes\Observation de " & Nom & " " & prenom & ".docm"
On Error Resume Next
ActiveDocument.Tables(1).Rows(1).Cells(1).Select
Selection.Range.Case = wdLowerCase
Selection.EndKey Unit:=wdLine
Selection.TypeBackspace
ActiveDocument.Tables(1).Rows(1).Cells(3).Select
Selection.EndKey Unit:=wdLine
Selection.TypeBackspace
ActiveDocument.Tables(1).Rows(1).Cells(2).Select
Selection.Range.Case = wdLowerCase
Selection.EndKey Unit:=wdLine
Selection.TypeBackspace
Set FichierWord = GetObject(file3)
If FichierWord = ActiveDocument Then
Else
Documents.Open FileName:=file3
End If
With Documents("Transmission.docm")
Application.ScreenUpdating = False
.Select
Selection.Find.ClearFormatting
With Selection.Find
.Text = datearive
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.MoveLeft Unit:=wdCharacter, Count:=1
'Selection.MoveUp Unit:=wdScreen, Count:=1000, Extend:=wdExtend
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.Copy
Application.ScreenUpdating = True
End With
Documents.Open FileName:=file2
ChangeFileOpenDirectory _
file
ActiveDocument.SaveAs2 FileName:="recup.docm", _
FileFormat:=wdFormatXMLDocumentMacroEnabled
With Documents("recup.docm")
Application.ScreenUpdating = False
Selection.Paste
For i = 1 To .Paragraphs.Count
.Paragraphs(i).Range.Select
If InStr(1, Selection.Text, prenom, vbTextCompare) > 0 Then
Selection.Copy
With Documents("Observation de " & Nom & " " & prenom & ".docm")
.Select
With Selection
Selection.GoTo What:=wdGoToLine, Which:=wdGoToFirst, Count:=7, Name:=""
Selection.Range.Paste
End With
Application.ScreenUpdating = True
End With
End If
Next i
End With
With Documents("Observation de " & Nom & " " & prenom & ".docm")
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
For j = 1 To .Paragraphs.Count
.Paragraphs(j).Range.Select
If InStr(1, Selection.Text, "Extérieur", vbTextCompare) > 0 Then
Selection.Delete
End If
Next j
End With
Documents("recup.docm").Close SaveChanges:=wdDoNotSaveChanges
Kill (file & "recup.docm")
End Sub
Public Function netText(stTemp As String)
netText = Left(stTemp, (Len(stTemp) - 2))
End Function |
Partager