Sub AjoutSautDeSection() ' Created by 3ddI7IHd ' Creation date: 20-05-2009 ' Code Reason: ' Pour pouvoir tenir compte de l'orientation des pages il faut que ' les pages soit séparées par un saut de section(page suivante) ' Ce sub a donc pour objectif de créer un saut de section a la fin ' de chaque page ou de remplacer le saut existant par un saut de section ' La complexité de cette sub est du à tout les cas possibles en fin de page ' ' Modified by 3ddI7IHd ' Modfication date: 15-04-2011 ' Change Reason: prise en compte de particularités liée aux pages 'qui se termines par un sommaire, un hyperlink, une table, une objet (Shape,image etc) ou 'uniquement par un caractère alphanumérique. Dim i As Long, j As Long, nbpage As Long, keepselect As Range, n As Long, LineToRepeat As Range Dim OrientationPageSelect As Long, MargeG As Single, MargeD As Single, Message As String Dim Vsize As Single, Hsize As Single, Ligne As Long, Col As Long, NbLineToRepeat As Long Dim Sommaire As Object, MonObject As Object, MesShapes As Object, MaShape As Object Dim LastLineVPosition As Long, NbShapeOut As Single, CheckContenu As Long 'Recuperation du nombre de page nbpage = ActiveDocument.ActiveWindow.Panes(1).Pages.Count ' on boucle sur chaque page en commencent par l'avant derniere, ' le sens de la boucle permet de conserver la mise en page sauf si une table se trouve ' sur plusieurs page. RetourTableSurPlusieursPages: For i = nbpage - 1 To 1 Step -1 'For i = 24 To 1 Step -1 'If i = 15 Then Stop 'on active la page Selection.GoTo wdGoToPage, , , CStr(i) 'on selectionne tout le contenu (saut existant inclu) ActiveDocument.Bookmarks("\page").Range.Select With Selection If .Characters.Count < 2 Then CheckContenu = .Tables.Count + .Hyperlinks.Count + .Bookmarks.Count CheckContenu = CheckContenu + .FormFields.Count + .ShapeRange.Count If CheckContenu = 0 Then .Delete nbpage = i GoTo RetourTableSurPlusieursPages End If End If End With 'on pose dans une variable object tout les Shapes de la section courante 'ceci permetra de verifier qu'aucun d'entre eux n'est passé sur la page suivante 'lors de la creation du saut de page. On Error Resume Next Set MesShapes = Selection.Range.ShapeRange On Error GoTo 0 'on met de coté le range selectioné Set keepselect = Selection.Range 'on ce deplace a droite ce qui a pour effet de positionner ' le curseur en fin de page Selection.MoveRight Unit:=wdCharacter, Count:=1 'on remonte d'un caractere pour ce placer avant l'eventuel saut de page Selection.MoveLeft Unit:=wdCharacter, Count:=1 'on verifi que l'on est bien sur la page demandée If Selection.Information(wdActiveEndPageNumber) > i Then 'si l'on est pas sur la page demandée. 'Cela arrive quand le texte sous forme d'un paragraphe(sommaire) 'déborde sur plusieurs pages. on vas donc rechercher la page en 'remontant caractere par caractere jusqu'a trouver la bonne page. Do Selection.MoveLeft Unit:=wdCharacter, Count:=1 Loop Until Selection.Information(wdActiveEndPageNumber) = i If Asc(Selection) = 12 Then Selection.Delete wdCharacter, 1 Else Selection.MoveRight Unit:=wdCharacter, Count:=1 End If Selection.InsertBreak Type:=wdSectionBreakNextPage 'Stop Else Selection.MoveLeft Unit:=wdCharacter, Count:=1 'on met de coté son orientation d'origine With Selection.PageSetup On Local Error Resume Next OrientationPageSelect = .Orientation MargeG = .LeftMargin MargeD = .RightMargin Hsize = .PageWidth Vsize = .PageHeight End With 'avons-nous affaire à un sommaire ? If ActiveDocument.TablesOfContents.Count > 0 Then For Each Sommaire In ActiveDocument.TablesOfContents 'si la selection ce trouve dans le text du sommaire If Selection.InRange(Sommaire.Range) = True Then Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.TypeParagraph Selection.MoveLeft Unit:=wdCharacter, Count:=1 Exit For End If Next End If 'avons-nous affaire a lien (Hyperlinks) If Not Selection.Hyperlinks.Count = 0 Then Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.TypeParagraph Selection.MoveLeft Unit:=wdCharacter, Count:=1 End If 'avons nous affaire a une table ? If Selection.Information(wdWithInTable) = True Then 'selection de la derniere cellule du tableau Selection.Tables(1).Select Selection.Cells(Selection.Cells.Count).Select Ligne = Selection.Cells(Selection.Cells.Count).RowIndex Col = Selection.Cells(Selection.Cells.Count).ColumnIndex ' le tableau est'il à cheval sur plusieurs page ? If Not Selection.Information(wdActiveEndPageNumber) = i Then 'recupperation de la premiere page qui contien le tableau Selection.Tables(1).Cell(1, 1).Select nbpage = Selection.Information(wdActiveEndPageNumber) Message = "The table on page " & nbpage & " is biger than the format of the current page /!\ " & Chr(10) & _ "In order to continu MSWord need the number of line to repeat on next page(s) for this table." & Chr(10) & Chr(10) & _ "Please enter the number of line to repeat. (0=no line to repeat)" Do Err.Clear On Local Error Resume Next NbLineToRepeat = Abs(Fix(InputBox(Message, "=S= Template...", 0))) If Not Err = 0 Then MsgBox "Please enter a number ! ", vbExclamation DoEvents Loop While Not Err = 0 n = nbpage Do Ligne = 1 Selection.GoTo wdGoToPage, , , CStr(n) If Selection.Information(wdWithInTable) = False Then ActiveDocument.Bookmarks("\page").Range.Select Selection.MoveRight Unit:=wdCharacter, Count:=1 End If If NbLineToRepeat > 0 And n = nbpage Then Selection.Tables(1).Cell(1, 1).Select Set LineToRepeat = ActiveDocument.Range(Selection.Tables(1).Cell(1, 1) _ .Range.Start, Selection.Tables(1).Cell(NbLineToRepeat, Col).Range.End) LineToRepeat.Select Selection.SelectRow Set LineToRepeat = Selection.Range ElseIf NbLineToRepeat > 0 And n > nbpage Then LineToRepeat.Copy Selection.Tables(1).Cell(1, 1).Select Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.Paste End If Do Ligne = Ligne + 1 If Ligne > Selection.Tables(1).Rows.Count Then Exit Do Err.Clear On Local Error Resume Next Selection.Tables(1).Cell(Ligne, Col).Select DoEvents Loop While Selection.Information(wdActiveEndPageNumber) n Or Not Err 0 'Stop 'If Not Selection.Information(wdActiveEndAdjustedPageNumber) = i Then If Ligne - 1 < Selection.Tables(1).Rows.Count Then Do Do Selection.Tables(1).Cell(Ligne, Col).Select Selection.SelectRow Ligne = Ligne - 1 DoEvents Loop While Not Selection.Tables(1).Columns.Count = Selection.Columns.Count Selection.SplitTable ' si l'on est pas sur la page precedente c'est qu'il n'y a pas de place pour la ligne saut de page ' donc on remonte pour fractioner le tableau plus haut If Not Selection.Information(wdActiveEndPageNumber) = n Then Selection.Delete wdCharacter, 1 Ligne = Ligne + 1 Do While Not Selection.Information(wdActiveEndPageNumber) <= n Ligne = Ligne - 1 Selection.Tables(1).Cell(Ligne, Col).Select DoEvents If Ligne = 1 Then Exit Do Loop Else Exit Do End If Loop Else nbpage = ActiveDocument.ActiveWindow.Panes(1).Pages.Count Exit Do 'ActiveDocument.Bookmarks("\page").Range.Select 'Selection.Range.Characters.Last.Select End If If Asc(Selection) = 12 Then 'si oui Selection.InsertBreak Type:=wdSectionBreakNextPage Selection.Delete wdCharacter, 1 Exit Do Else 'si non 'on ajoute un retour chariot pour preserver la mise en page du text qui suivra le saut de section Selection.TypeParagraph 'on insert le saut de section Selection.InsertBreak Type:=wdSectionBreakNextPage 'on supprime le retour chariot précédemment créé Selection.Delete Unit:=wdCharacter, Count:=1 End If 'le nombre de page a t'il changé ? Selection.Tables(1).Cell(Selection.Tables(1).Rows.Count, Col).Select If Not i Selection.Information(wdActiveEndPageNumber) Then i Selection.Information(wdActiveEndPageNumber) n = n + 1 'If n = 22 Then Stop DoEvents Loop Until n > i NbLineToRepeat = 0 GoTo RetourTableSurPlusieursPages Else Selection.Tables(1).Cell(Ligne, Col).Select Selection.MoveRight Unit:=wdCharacter, Count:=1 End If End If 'si la selection n'est pas un retour a la ligne et n'est 'pas une fin de paragraphe ou est un tableau If (Not Asc(Selection) 10 And Not Asc(Selection) 13) Or Selection.Information(wdWithInTable) = True Then Do While Selection.Information(wdWithInTable) True Or (Not Asc(Selection) 10 And Not Asc(Selection) = 13) 'MsgBox Asc(Selection) Selection.MoveRight Unit:=wdCharacter, Count:=1 DoEvents If Selection.Information(wdActiveEndPageNumber) > i Then Selection.MoveLeft Unit:=wdCharacter, Count:=1 Exit Do End If Loop If Not Asc(Selection) 10 And Not Asc(Selection) 13 Then Selection.TypeParagraph Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend Selection.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph With Selection.ParagraphFormat .SpaceBefore = 0 .SpaceBeforeAuto = False .SpaceAfter = 0 .SpaceAfterAuto = False .LineSpacingRule = wdLineSpaceSingle .PageBreakBefore = False .LineUnitBefore = 0 .LineUnitAfter = 0 End With With Selection.Font .Bold = False .Italic = False .Underline = wdUnderlineNone .Size = 10 End With End If Selection.MoveRight Unit:=wdCharacter, Count:=1 Else LastLineVPosition = Selection.Information(wdVerticalPositionRelativeToPage) Selection.MoveRight Unit:=wdCharacter, Count:=1 If Not Round(Selection.Information(wdVerticalPositionRelativeToPage)) LastLineVPosition And Not Asc(Selection) 12 Then 'si on est ici c'est que le dernier objet de la page doit être un ShapeRange NbShapeOut = 0 If Not MesShapes.Count = 0 Then For Each MaShape In MesShapes MaShape.RelativeVerticalPosition = wdRelativeVerticalPositionPage If MaShape.Top > LastLineVPosition Then NbShapeOut = NbShapeOut + 1 Next If NbShapeOut = 1 Then MesShapes.Item(1).Select Selection.Cut Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.Paste Selection.MoveRight Unit:=wdCharacter, Count:=2 End If End If End If End If 'Recherche d'un pied de page a la position du curseur. Le caractere 12 est un saut de page If Asc(Selection) = 12 Then 'si oui Selection.InsertBreak Type:=wdSectionBreakNextPage Selection.Delete wdCharacter, 1 Else 'si non 'on ce place place sur la zone d'insertion du saut section Selection.MoveLeft Unit:=wdCharacter, Count:=1 'on ajoute un retour chariot pour preserver la mise en page du text qui suivra le saut de section Selection.TypeParagraph Selection.EndOf wdLine, wdMove If Not Asc(Selection) = 12 Then 'on insert le saut de section Selection.InsertBreak Type:=wdSectionBreakNextPage 'on supprime le retour chariot précédemment créé Selection.Delete Unit:=wdCharacter, Count:=1 End If End If 'le nombre de page a t'il changé ? 'If Not i Selection.Information(wdActiveEndPageNumber) Then i Selection.Information(wdActiveEndPageNumber) On Error Resume Next If Not MesShapes.Count 0 And Not ActiveDocument.Sections(Selection.Information(wdActiveEndSectionNumber)).Range.ShapeRange.Count 0 Then If Err = 0 Then For Each MonObject In ActiveDocument.Sections(Selection.Information(wdActiveEndSectionNumber)).Range.ShapeRange For Each MaShape In MesShapes 'j = j + 1 If MonObject.Name = MaShape.Name And Selection.Information(wdActiveEndPageNumber) > i Then Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.Delete Unit:=wdCharacter, Count:=1 Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.TypeParagraph Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.InsertBreak Type:=wdSectionBreakNextPage Selection.Delete Unit:=wdCharacter, Count:=1 End If Next Next End If End If On Error GoTo 0 'on s'assure d'etre sur la bonne page avant de lui redonner sa mise en page If Selection.Information(wdActiveEndPageNumber) > i Then Selection.MoveLeft Unit:=wdCharacter, Count:=1 ' on selectionne le range precedent pour lui redonner sa mise en page keepselect.Select With Selection.PageSetup Err.Clear On Local Error Resume Next If Not .Orientation = OrientationPageSelect Then If Err = 0 Then .Orientation = OrientationPageSelect ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter Selection.Tables(1).Rows.Select Selection.HeaderFooter.LinkToPrevious = True Selection.GoTo wdGoToPage, , , CStr(i) End If Else On Local Error Resume Next .Orientation = OrientationPageSelect End If .LeftMargin = MargeG .RightMargin = MargeD .PageWidth = Hsize .PageHeight = Vsize End With End If Application.ScreenRefresh If z > 1 Then z = z - 1 z = z + (10 / Abs(nbpage)) Next End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question