Option Explicit
Sub DecoupageDoc()
Dim NomDocDepart As String
Dim i As Long, j As Long
Dim Termine As Boolean
Dim NumeroDoc As String, PgDepart As Long
Dim Dossier As String, DossierSauvegarde As String
Dim NbPages As Long
Const DecouperEn As Integer = 10
Application.ScreenUpdating = False
NomDocDepart = ActiveDocument.Name
NbPages = ActiveDocument.Content.ComputeStatistics(wdStatisticPages)
Dossier = ActiveDocument.Path
DossierSauvegarde = Dossier & "\" & "Charcuterie"
VerifDossier DossierSauvegarde
Selection.EndKey Unit:=wdStory
Selection.HomeKey Unit:=wdStory
i = 0
Termine = False
ChangeFileOpenDirectory DossierSauvegarde
Do While True
i = i + 1
NumeroDoc = Trim(Str(i))
Do While Len(NumeroDoc) < 4
NumeroDoc = "0" + NumeroDoc
Loop
PgDepart = Selection.Range.Start
For j = 1 To DecouperEn
Application.Browser.Next
Next
If Selection.Range.Start = PgDepart Then
Termine = True
Selection.EndKey Unit:=wdStory
Else
Selection.MoveLeft Unit:=wdCharacter, Count:=1
End If
ActiveDocument.Range(Start:=PgDepart, End:=Selection.Range.Start).Copy
Documents.Add Template:="Normal", NewTemplate:=False
Selection.Paste
ActiveDocument.SaveAs FileName:=Left(NomDocDepart, Len(NomDocDepart) - 4) + _
"_" + NumeroDoc + ".doc", FileFormat:=wdFormatDocument
ActiveDocument.Close
Documents(NomDocDepart).Activate
If Termine Then Exit Do
Selection.MoveRight Unit:=wdCharacter, Count:=1
Loop
Application.ScreenUpdating = True
End Sub
Private Sub VerifDossier(ByVal DossierSauvegarde As String)
On Error GoTo erreur
ChDir DossierSauvegarde
Exit Sub
erreur:
If Err.Number = 76 Then
MkDir DossierSauvegarde
Resume Next
End If
End Sub |