Option Base 0
Sub Integration()
Dim NomR, NomF(3000) As String
Dim iMax As Integer
Message = "Entrez le chemin sur lequel se trouvent les fichiers HTM" ' Définit le message.
Title = "Saisie du répertoire de travail" ' Définit le titre.
NomR = "D:\_Data\TransfertsTemp\" ' Définit la valeur par défaut.
NomR = InputBox(Message, Title, NomR)
If NomR = "" Then Exit Sub
If Len(Trim(Dir(NomR + "1-Cumul.doc"))) = 0 Then
MsgBox "Il faut que le fichier 1-Cumul.doc soit sur ce répertoire!"
Exit Sub
End If
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
Selection.Delete
NomF(0) = Dir(NomR & "*.htm")
Selection.TypeText Text:=NomF(0)
Selection.TypeParagraph
i = 0
Do While True
NomF(0) = Dir
If NomF(0) = "" Then Exit Do
Selection.TypeText Text:=NomF(0)
Selection.TypeParagraph
i = i + 1
Loop
iMax = i
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
Selection.Sort ExcludeHeader:=False, FieldNumber:="Paragraphes", _
SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
FieldNumber2:="", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:= _
wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _
wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _
wdSortSeparateByTabs, SortColumn:=False, CaseSensitive:=False, LanguageID _
:=wdFrench
Selection.HomeKey Unit:=wdStory
Selection.Delete
i = 0
Do While i < iMax + 1
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
NomF(i) = Selection.Text
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Delete
i = i + 1
Loop
i = 0
Do While i < iMax + 1
' Selection.TypeText Text:=NomF(i)
' Selection.Style = ActiveDocument.Styles("Titre 1")
' Selection.EndKey Unit:=wdLine
' Selection.TypeParagraph
Documents.Open FileName:=NomR + NomF(i), ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto
ActiveDocument.SaveAs FileName:=NomR + "Page.doc", FileFormat:=wdFormatDocument, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
ActiveDocument.Background.Fill.Visible = msoFalse
Selection.WholeStory
With Selection.Font
.Underline = wdUnderlineNone
.UnderlineColor = wdColorAutomatic
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Color = wdColorAutomatic
.Engrave = False
.Superscript = False
.Subscript = False
.Spacing = 0
.Scaling = 100
.Position = 0
.Kerning = 0
.Animation = wdAnimationNone
End With
Selection.HomeKey Unit:=wdStory
Selection.MoveDown Unit:=wdLine, Count:=2, Extend:=wdExtend
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^l"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.HomeKey Unit:=wdStory
Selection.Style = ActiveDocument.Styles("Titre 1")
' mise en page
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(1)
.BottomMargin = CentimetersToPoints(1)
.LeftMargin = CentimetersToPoints(1)
.RightMargin = CentimetersToPoints(1)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(0.8)
.FooterDistance = CentimetersToPoints(0.8)
.PageWidth = CentimetersToPoints(21)
.PageHeight = CentimetersToPoints(29.7)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.GutterPos = wdGutterPosLeft
End With
' fin de mise en page
' sélectionne entre 2 mots
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(0.8)
.BottomMargin = CentimetersToPoints(0.8)
.LeftMargin = CentimetersToPoints(1.5)
.RightMargin = CentimetersToPoints(0.5)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(0.7)
.FooterDistance = CentimetersToPoints(0.7)
.PageWidth = CentimetersToPoints(21)
.PageHeight = CentimetersToPoints(29.7)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = True
.TwoPagesOnOne = False
.GutterPos = wdGutterPosLeft
End With
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 12
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
Selection.Find.ClearFormatting
With Selection.Find
.Text = "(IDENT:)(*)($$)"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type <> wdPrintView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveDocument.Range(Start:=Selection.Start, End:=Selection.Start). _
InsertBreak Type:=wdSectionBreakContinuous
Selection.Start = Selection.Start + 1
ActiveDocument.Range(Start:=Selection.End, End:=Selection.End).InsertBreak _
Type:=wdSectionBreakContinuous
With Selection.PageSetup.TextColumns
.SetCount NumColumns:=2
.EvenlySpaced = True
.LineBetween = True
.Width = CentimetersToPoints(9.3)
.Spacing = CentimetersToPoints(0.4)
End With
' fin subroutine 2 colonnes
ActiveDocument.Save
ActiveDocument.Close
Selection.InsertFile FileName:=NomR + "Page.doc", Range:="", ConfirmConversions:= _
False, Link:=False, Attachment:=False
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 12
.SpaceBeforeAuto = False
.SpaceAfter = 3
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = True
.KeepTogether = False
.PageBreakBefore = True
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevel1
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
i = i + 1
Loop
ActiveDocument.Save
If Len(Trim(Dir(NomR + "Page.doc"))) > 0 Then Kill (NomR + "Page.doc")
With ActiveDocument.Styles("Titre 1")
.AutomaticallyUpdate = True
.BaseStyle = "Normal"
.NextParagraphStyle = "Normal"
End With
With ActiveDocument.Styles("Titre 1").Font
.Name = "Times New Roman"
.Size = 18
.Bold = True
.Italic = True
.Underline = wdUnderlineNone
.UnderlineColor = wdColorAutomatic
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = True
.Color = wdColorAutomatic
.Engrave = False
.Superscript = False
.Subscript = False
.Scaling = 100
.Kerning = 14
.Animation = wdAnimationNone
End With
With ActiveDocument.Styles("Titre 1").ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 12
.SpaceBeforeAuto = False
.SpaceAfter = 3
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphCenter
.WidowControl = True
.KeepWithNext = True
.KeepTogether = False
.PageBreakBefore = True
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevel1
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
Selection.Style = ActiveDocument.Styles("Titre 1")
Selection.HomeKey Unit:=wdStory
With ActiveDocument
.TablesOfContents.Add Range:=Selection.Range, RightAlignPageNumbers:= _
True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
LowerHeadingLevel:=1, IncludePageNumbers:=True, AddedStyles:="", _
UseHyperlinks:=True, HidePageNumbersInWeb:=True
.TablesOfContents(1).TabLeader = wdTabLeaderDots
.TablesOfContents.Format = wdIndexIndent
End With
End Sub