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 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302
| Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
'
Private Sub CommandButton1_Click()
'NÉCESSITE les fonctions "CorrectionAutomatiques_OpenACDoc" et "CorrectionAutomatiques_RestoreACEntries"
' First warns the user that this will replace their existing entries.
' If they answer no it jumps to the end of the function. Next calls CorrectionAutomatiques_OpenACDoc() to open
' the file. If successful it calls CorrectionAutomatiques_RestoreACEntries(). Finally, it closes the document.
Dim ACFileName, Title As String
Dim MsgBoxButtons As Long, Response As Long, X As Long
' warn users about replaced entries...
MsgBoxButtons = vbYesNo + vbInformation + vbDefaultButton2 ' Define buttons.
Title = "AutoCorrect Utility"
Response = MsgBox("Cette macro va remplacer toutes vos entrées de Corrections Automatiques avec celles contenues dans le document du Greffe si toutefois elles ont le même nom. Souhaitez-vous continuer?", MsgBoxButtons, Title)
If Response = vbNo Then
'exit
GoTo bye:
End If
'Nom du fichier où se trouve les Corrections automatiques
ACFileName = "\\villong\public\Juridique\jursecrgref\Administration du service\Setting informatique\zSettings_Greffe\Developpement\Word Developpement\Corrections automatiques\Greffe - Corrections et insertions automatiques - Officiel.doc"
' Open a Document,call CorrectionAutomatiques_OpenACDoc() user defined
If CorrectionAutomatiques_OpenACDoc(ACFileName) = True Then 'error
' Restore Entries, call CorrectionAutomatiques_RestoreACEntries() user defined
X = CorrectionAutomatiques_RestoreACEntries()
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End If
bye:
System.Cursor = wdCursorNormal
End Sub
Private Function CorrectionAutomatiques_RestoreACEntries()
'Fonction utilisée par CorrectionAutomatiques_integration_a_l_utilisatrice
Dim oDoc As Document, oACorrect As Object, oTable As Table, oRow As Row
Dim strName As String, strValue As String, strRTF As String, MyRange As Range, RTFRange As Range
Dim X As Long
Err.Clear
On Error GoTo 0
If ActiveDocument.Words(1) <> "rien" Then
'Vider la fenêtre de rechecher/remplacer via l'appel d'une macro:
Vider_ChercherRemplacer
'''''Application.ScreenUpdating = False
ActiveDocument.TablesOfContents(1).delete
'Efface les "F3"
With selection.Find
.Text = "^wf3"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
End With
'Va au tableau sinon se trouve sur la première page du doc
selection.GoTo What:=wdGoToTable, Which:=wdGoToNext, count:=1, Name:=""
If selection.Information(wdWithInTable) = True Then
' go to the last row
selection.Move Unit:=wdRow, count:=selection.tables(1).Rows.count
' go to the last cell of that row
selection.Move Unit:=wdCell, count:=selection.tables(1).Columns.count
' Now move down two lines, beyond the table end
selection.Move Unit:=wdLine, count:=2
End If
'Efface ce qui se trouve après le tableau
selection.EndKey Unit:=wdStory, Extend:=wdExtend
selection.delete Unit:=wdCharacter, count:=1
'La section suivante vérifie s'il y a des titres de section.
Do
selection.HomeKey Unit:=wdStory
selection.Find.Style = ActiveDocument.Styles("InsertionTitre1")
With selection.Find
.Text = "^?"
.Forward = True
.Wrap = wdFindContinue
End With
selection.Find.Execute
If selection.Find.Found = False Then
Else
selection.Rows.delete
End If
Loop While selection.Find.Found = True
selection.GoTo What:=wdGoToTable, Which:=wdGoToNext, count:=1, Name:=""
'Met en minuscule le nom de l'insertion
Dim aTable As Table
For Each aTable In ActiveDocument.tables
Dim aRow As Row
With aTable
For Each aRow In aTable.Range.Rows
aRow.Cells(1).Select
selection.Range.Case = wdLowerCase
Next
End With
Next
'Efface les lignes vides
Effacer_lignes_vides
'Vider la fenêtre de rechecher/remplacer via l'appel d'une macro:
Vider_ChercherRemplacer
Set oDoc = ActiveDocument
Set oTable = oDoc.tables(1)
Set oACorrect = Application.AutoCorrect.Entries
Set MyRange = oTable.Cell(2, 1).Range
MyRange.End = MyRange.End - 1
System.Cursor = wdCursorWait
Do
Application.ScreenUpdating = False
strName = MyRange.Text
Set MyRange = MyRange.Next(wdCell)
MyRange.End = MyRange.End - 1
'if AutoCorrect entry is a table then gets the entry, deletes the table within a table,
'and goes to next row if there are any more rows
If Not MyRange.tables(1).Range.IsEqual(oTable.Range) Then
Application.AutoCorrect.Entries.AddRichText strName, MyRange
MyRange.Cut
If IsObjectValid(MyRange.Next(wdCell, 2)) Then
Set MyRange = MyRange.Next(wdCell, 2)
MyRange.End = MyRange.End - 1
GoTo NextLoop
Else
Exit Do
End If
End If
strValue = MyRange.Text
Set RTFRange = MyRange.Next(wdCell)
RTFRange.End = RTFRange.End - 1
strRTF = RTFRange.Text
Application.StatusBar = "Adding AutoCorrect Entry: " & strName
If strRTF = "False" Then
Application.AutoCorrect.Entries.Add Name:=strName, Value:=strValue
Else
Application.AutoCorrect.Entries.AddRichText strName, MyRange
End If
If IsObjectValid(RTFRange.Next(wdCell)) Then
Set MyRange = RTFRange.Next(wdCell)
MyRange.End = MyRange.End - 1
Else
Exit Do
End If
NextLoop:
Loop
System.Cursor = wdCursorNormal
Application.ScreenUpdating = True
MsgBox "Intégration des corrections automatiques du greffe terminée"
Else
MsgBox "Erreur"
End If
'Vide le presse-papier
ViderPressePapier
CorrectionAutomatiques_RestoreACEntriesErrors:
Select Case Err.Number
Case 0:
' no error
Case Else
MsgBox ("There was an error. The document may be in the incorrect format." & vbCr & Err.Number & " " & Err.Description & " " & strName)
End Select
End Function
Public Sub ViderPressePapier()
'Ouverture du presse-papier
OpenClipboard 0&
'On vide le presse-papier
EmptyClipboard
'Fermeture du presse-papier
CloseClipboard
End Sub
Private Function CorrectionAutomatiques_OpenACDoc(ByVal ACFileOpenName As String) As Boolean
'Fonction utilisée par CorrectionAutomatiques_integration_a_l_utilisatrice
Dim MsgBoxButtons As Long
CorrectionAutomatiques_OpenACDoc = True
On Error GoTo CorrectionAutomatiques_OpenACDocErrors
Documents.Open FileName:=ACFileOpenName
On Error GoTo 0
Exit Function
CorrectionAutomatiques_OpenACDocErrors:
CorrectionAutomatiques_OpenACDoc = False
End Function
Sub Vider_ChercherRemplacer()
'Macro appelée à la fin de d'autres macros pour remettre
'le rechercher remplacer à zéro
'NE PAS EFFACER CETTE MACRO
With selection.Find
.ClearFormatting
.Text = ""
.Replacement.ClearFormatting
.Replacement.Text = ""
.MatchAllWordForms = False
.MatchCase = False
.MatchSoundsLike = False
.MatchWholeWord = False
.MatchWildcards = False
.Wrap = wdFindContinue
.Forward = True
.Format = False
End With
End Sub
Sub Effacer_lignes_vides()
'Deleting all empty rows in a table
''Note that you could delete the empty rows from all tables in a document by replacing the line:
'' Set oTable = Selection.Tables(1)
''With the line
'' For Each oTable In ActiveDocument.Tables
''and adding the line:
'' Next oTable
''just Before:
'' Application.ScreenUpdating = True
Dim oTable As Table, oRow As Range, oCell As Cell, Counter As Long, _
NumRows As Long, TextInRow As Boolean
' Specify which table you want to work on.
Set oTable = selection.tables(1)
' Set a range variable to the first row's range
Set oRow = oTable.Rows(1).Range
NumRows = oTable.Rows.count
Application.ScreenUpdating = False
For Counter = 1 To NumRows
StatusBar = "Row " & Counter
TextInRow = False
For Each oCell In oRow.Rows(1).Cells
If Len(oCell.Range.Text) > 2 Then
'end of cell marker is actually 2 characters
TextInRow = True
Exit For
End If
Next oCell
If TextInRow Then
Set oRow = oRow.Next(wdRow)
Else
oRow.Rows(1).delete
End If
Next Counter
Application.ScreenUpdating = True
End Sub |
Partager